Index: generic/gentclAPI.decls =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -8,7 +8,7 @@ xotclCmd "::xotcl" objectMethod "::xotcl::cmd::Object" classMethod "::xotcl::cmd::Class" - checkMethod "::xotcl::cmd::NonposArgs" + checkMethod "::xotcl::cmd::ParameterType" infoClassMethod "::xotcl::cmd::ClassInfo" infoObjectMethod "::xotcl::cmd::ObjectInfo" } @@ -36,6 +36,12 @@ {-argName "oldCmd" -required 1} {-argName "newCmd" -required 0} } +xotclCmd dispatch XOTclDispatchCmd { + {-argName "object" -required 1 -type object} + {-argName "methodName" -required 1} + {-argName "-objscope"} + {-argName "args" -type args} +} xotclCmd finalize XOTclFinalizeObjCmd { } xotclCmd instvar XOTclInstvarCmd { @@ -145,6 +151,11 @@ objectMethod procsearch XOTclOProcSearchMethod { {-argName "name" -required 1} } +# "set" needed? +objectMethod set XOTclOSetMethod { + {-argName "var" -required 1 -type tclobj} + {-argName "value" -type tclobj} +} objectMethod requireNamespace XOTclORequireNamespaceMethod { } objectMethod setvalues XOTclOSetvaluesMethod { Index: generic/gentclAPI.tcl =================================================================== diff -u -r485f041db31fc83046fbeba0d3e64beeb1abca1f -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 485f041db31fc83046fbeba0d3e64beeb1abca1f) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -25,7 +25,7 @@ set enums [list] foreach d $domain {lappend enums $argname[string totitle [string map [list - _] $d]]Idx} subst { -static int convertTo${name}(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertTo${name}(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { $opts return Tcl_GetIndexFromObj(interp, objPtr, opts, "$argname", 0, (int *)clientData); } Index: generic/predefined.h =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/predefined.h (.../predefined.h) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/predefined.h (.../predefined.h) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -13,17 +13,17 @@ "set bootstrap 1\n" "foreach cmd [info command ::xotcl::cmd::Object::*] {\n" "::xotcl::alias ::xotcl::Object [namespace tail $cmd] $cmd}\n" -"foreach cmd {array append eval incr lappend set subst unset trace} {\n" +"foreach cmd {array append eval incr lappend subst unset trace} {\n" "::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd}\n" "foreach cmd [info command ::xotcl::cmd::Class::*] {\n" "::xotcl::alias ::xotcl::Class [namespace tail $cmd] $cmd}\n" "::xotcl::Object instproc init args {}\n" "::xotcl::Object instproc objectparameter {} {;}\n" -"::xotcl::Class create ::xotcl::NonposArgs\n" -"foreach cmd [info command ::xotcl::cmd::NonposArgs::*] {\n" -"::xotcl::alias ::xotcl::NonposArgs [namespace tail $cmd] $cmd}\n" -"::xotcl::alias ::xotcl::NonposArgs type=switch ::xotcl::cmd::NonposArgs::type=boolean\n" -"::xotcl::NonposArgs create ::xotcl::nonposArgs\n" +"::xotcl::Class create ::xotcl::ParameterType\n" +"foreach cmd [info command ::xotcl::cmd::ParameterType::*] {\n" +"::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd}\n" +"::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean\n" +"::xotcl::ParameterType create ::xotcl::parameterType\n" "::xotcl::Object create ::xotcl::objectInfo\n" "::xotcl::Object create ::xotcl::classInfo\n" "foreach cmd [info command ::xotcl::cmd::ObjectInfo::*] {\n" Index: generic/predefined.xotcl =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/predefined.xotcl (.../predefined.xotcl) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/predefined.xotcl (.../predefined.xotcl) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -63,7 +63,7 @@ } # provide some Tcl-commands as methods for ::xotcl::Object - foreach cmd {array append eval incr lappend set subst unset trace} { + foreach cmd {array append eval incr lappend subst unset trace} { ::xotcl::alias ::xotcl::Object $cmd -objscope ::$cmd } @@ -80,14 +80,14 @@ # # create class and object for nonpositional argument processing - ::xotcl::Class create ::xotcl::NonposArgs - foreach cmd [info command ::xotcl::cmd::NonposArgs::*] { - ::xotcl::alias ::xotcl::NonposArgs [namespace tail $cmd] $cmd + ::xotcl::Class create ::xotcl::ParameterType + foreach cmd [info command ::xotcl::cmd::ParameterType::*] { + ::xotcl::alias ::xotcl::ParameterType [namespace tail $cmd] $cmd } # register type boolean as checker for "switch" - ::xotcl::alias ::xotcl::NonposArgs type=switch ::xotcl::cmd::NonposArgs::type=boolean + ::xotcl::alias ::xotcl::ParameterType type=switch ::xotcl::cmd::ParameterType::type=boolean # create an object for dispatching - ::xotcl::NonposArgs create ::xotcl::nonposArgs + ::xotcl::ParameterType create ::xotcl::parameterType ######################## # Info definition Index: generic/tclAPI.h =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/tclAPI.h (.../tclAPI.h) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/tclAPI.h (.../tclAPI.h) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -1,17 +1,17 @@ -static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToConfigureoption(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { static CONST char *opts[] = {"filter", "softrecreate", "cacheinterface", NULL}; return Tcl_GetIndexFromObj(interp, objPtr, opts, "configureoption", 0, (int *)clientData); } enum configureoptionIdx {configureoptionFilterIdx, configureoptionSoftrecreateIdx, configureoptionCacheinterfaceIdx}; -static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToMethodproperty(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { static CONST char *opts[] = {"protected", "public", "slotobj", NULL}; return Tcl_GetIndexFromObj(interp, objPtr, opts, "methodproperty", 0, (int *)clientData); } enum methodpropertyIdx {methodpropertyProtectedIdx, methodpropertyPublicIdx, methodpropertySlotobjIdx}; -static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToRelationtype(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { static CONST char *opts[] = {"mixin", "instmixin", "object-mixin", "class-mixin", "filter", "instfilter", "object-filter", "class_filter", "class", "superclass", "rootclass", NULL}; return Tcl_GetIndexFromObj(interp, objPtr, opts, "relationtype", 0, (int *)clientData); } @@ -39,7 +39,7 @@ "::xotcl::cmd::ObjectInfo", "::xotcl::cmd::Object", "::xotcl::cmd::ClassInfo", - "::xotcl::cmd::NonposArgs", + "::xotcl::cmd::ParameterType", "::xotcl::cmd::Class" }; static int XOTclCheckBooleanArgsStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -124,6 +124,7 @@ static int XOTclOProcMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOProcSearchMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclORequireNamespaceMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclOSetMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOSetvaluesMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUplevelMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOUpvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -133,6 +134,7 @@ static int XOTclConfigureCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCreateObjectSystemCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclDeprecatedCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclDispatchCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclFinalizeObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclInstvarCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclMethodPropertyCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); @@ -222,6 +224,7 @@ static int XOTclOProcMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *name, Tcl_Obj *args, Tcl_Obj *body, Tcl_Obj *precondition, Tcl_Obj *postcondition); static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name); static int XOTclORequireNamespaceMethod(Tcl_Interp *interp, XOTclObject *obj); +static int XOTclOSetMethod(Tcl_Interp *interp, XOTclObject *obj, Tcl_Obj *var, Tcl_Obj *value); static int XOTclOSetvaluesMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOUplevelMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); @@ -231,6 +234,7 @@ static int XOTclConfigureCmd(Tcl_Interp *interp, int configureoption, Tcl_Obj *value); static int XOTclCreateObjectSystemCmd(Tcl_Interp *interp, char *rootClass, char *rootMetaClass); static int XOTclDeprecatedCmd(Tcl_Interp *interp, char *oldCmd, char *newCmd); +static int XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withObjscope, int nobjc, Tcl_Obj *CONST nobjv[]); static int XOTclFinalizeObjCmd(Tcl_Interp *interp); static int XOTclInstvarCmd(Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int XOTclMethodPropertyCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withPer_object, int methodproperty, Tcl_Obj *value); @@ -321,6 +325,7 @@ XOTclOProcMethodIdx, XOTclOProcSearchMethodIdx, XOTclORequireNamespaceMethodIdx, + XOTclOSetMethodIdx, XOTclOSetvaluesMethodIdx, XOTclOUplevelMethodIdx, XOTclOUpvarMethodIdx, @@ -330,6 +335,7 @@ XOTclConfigureCmdIdx, XOTclCreateObjectSystemCmdIdx, XOTclDeprecatedCmdIdx, + XOTclDispatchCmdIdx, XOTclFinalizeObjCmdIdx, XOTclInstvarCmdIdx, XOTclMethodPropertyCmdIdx, @@ -2000,6 +2006,26 @@ } static int +XOTclOSetMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + XOTclObject *obj = (XOTclObject *)clientData; + if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); + if (ArgumentParse(interp, objc, objv, obj, objv[0], + method_definitions[XOTclOSetMethodIdx].paramDefs, + method_definitions[XOTclOSetMethodIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + Tcl_Obj *var = (Tcl_Obj *)pc.clientData[0]; + Tcl_Obj *value = (Tcl_Obj *)pc.clientData[1]; + + parseContextRelease(&pc); + return XOTclOSetMethod(interp, obj, var, value); + + } +} + +static int XOTclOSetvaluesMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { XOTclObject *obj = (XOTclObject *)clientData; if (!obj) return XOTclObjErrType(interp, objv[0], "Object"); @@ -2148,6 +2174,26 @@ } static int +XOTclDispatchCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (ArgumentParse(interp, objc, objv, NULL, objv[0], + method_definitions[XOTclDispatchCmdIdx].paramDefs, + method_definitions[XOTclDispatchCmdIdx].nrParameters, + &pc) != TCL_OK) { + return TCL_ERROR; + } else { + XOTclObject *object = (XOTclObject *)pc.clientData[0]; + char *methodName = (char *)pc.clientData[1]; + int withObjscope = (int )pc.clientData[2]; + + parseContextRelease(&pc); + return XOTclDispatchCmd(interp, object, methodName, withObjscope, objc-pc.lastobjc, objv+pc.lastobjc); + + } +} + +static int XOTclFinalizeObjCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { parseContext pc; @@ -2256,11 +2302,11 @@ } static methodDefinition method_definitions[] = { -{"::xotcl::cmd::NonposArgs::type=boolean", XOTclCheckBooleanArgsStub, 2, { +{"::xotcl::cmd::ParameterType::type=boolean", XOTclCheckBooleanArgsStub, 2, { {"name", 1, 0, convertToString}, {"value", 0, 0, convertToTclobj}} }, -{"::xotcl::cmd::NonposArgs::type=required", XOTclCheckRequiredArgsStub, 2, { +{"::xotcl::cmd::ParameterType::type=required", XOTclCheckRequiredArgsStub, 2, { {"name", 1, 0, convertToString}, {"value", 0, 0, convertToTclobj}} }, @@ -2598,6 +2644,10 @@ {"::xotcl::cmd::Object::requireNamespace", XOTclORequireNamespaceMethodStub, 0, { } }, +{"::xotcl::cmd::Object::set", XOTclOSetMethodStub, 2, { + {"var", 1, 0, convertToTclobj}, + {"value", 0, 0, convertToTclobj}} +}, {"::xotcl::cmd::Object::setvalues", XOTclOSetvaluesMethodStub, 1, { {"args", 0, 0, convertToNothing}} }, @@ -2633,6 +2683,12 @@ {"oldCmd", 1, 0, convertToString}, {"newCmd", 0, 0, convertToString}} }, +{"::xotcl::dispatch", XOTclDispatchCmdStub, 4, { + {"object", 1, 0, convertToObject}, + {"methodName", 1, 0, convertToString}, + {"-objscope", 0, 0, convertToString}, + {"args", 0, 0, convertToNothing}} +}, {"::xotcl::finalize", XOTclFinalizeObjCmdStub, 0, { } }, Index: generic/xotcl.c =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/xotcl.c (.../xotcl.c) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/xotcl.c (.../xotcl.c) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -1349,6 +1349,37 @@ return SearchPLMethod(ComputeOrder(cl, cl->order, Super), nm, cmd); } +/* + * Find a method for a given object in the precedence path + */ +static Tcl_Command +ObjectFindMethod(Tcl_Interp *interp, XOTclObject *obj, char *name, XOTclClass **pcl) { + Tcl_Command cmd = NULL; + + if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) + MixinComputeDefined(interp, obj); + + if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { + XOTclCmdList *mixinList; + for (mixinList = obj->mixinOrder; mixinList; mixinList = mixinList->nextPtr) { + XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr)); + if (mcl && (*pcl = SearchCMethod(mcl, name, &cmd))) { + break; + } + } + } + + if (!cmd && obj->nsPtr) { + cmd = FindMethod(obj->nsPtr, name); + } + + if (!cmd && obj->cl) + *pcl = SearchCMethod(obj->cl, name, &cmd); + + return cmd; +} + + static int callDestroyMethod(Tcl_Interp *interp, XOTclObject *obj, int flags) { int result; @@ -4840,7 +4871,7 @@ Tcl_AppendToObj(nameStringObj, option, -1); } -static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData); +static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, struct XOTclParam CONST *pPtr, ClientData *clientData); static Tcl_Obj * ParamDefsFormat(Tcl_Interp *interp, XOTclParamDefs *paramDefs) { @@ -5515,15 +5546,16 @@ /* todo: maybe, we will need this for custom type checkers, so leave it for the time being */ static Tcl_Obj* nonposargType(Tcl_Interp *interp, char *start, int len) { - Tcl_Obj *result = Tcl_NewListObj(0, NULL); - Tcl_Obj *type = Tcl_NewStringObj(start, len); + /*Tcl_Obj *result = Tcl_NewListObj(0, NULL); + Tcl_Obj *type = Tcl_NewStringObj(start, len);*/ Tcl_Obj *checker = Tcl_NewStringObj("type=", 5); Tcl_AppendToObj(checker, start, len); + /* TODO CLEANUP Tcl_ListObjAppendElement(interp, result, type); Tcl_ListObjAppendElement(interp, result, checker); - /*fprintf(stderr, "nonposargType TYPE = '%s'\n", ObjStr(result));*/ - return result; + */ + return checker; } #define NEW_STRING(target,p,l) target = ckalloc(l+1); strncpy(target,p,l); *((target)+l) = '\0' @@ -5544,53 +5576,68 @@ * type converter */ /* we could define parameterTypes with a converter, setter, canCheck, name */ -static int convertToString(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToString(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { *clientData = (char *)ObjStr(objPtr); return TCL_OK; } -static int convertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToTclobj(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { *clientData = (ClientData)objPtr; return TCL_OK; } -static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToNothing(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { return TCL_OK; } -static int convertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToBoolean(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int result, bool; result = Tcl_GetBooleanFromObj(interp, objPtr, &bool); if (result == TCL_OK) *clientData = (ClientData)bool; return result; } -static int convertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToInteger(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { int result, i; result = Tcl_GetIntFromObj(interp, objPtr, &i); if (result == TCL_OK) *clientData = (ClientData)i; return result; } -static int convertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { - return convertToBoolean(interp, objPtr, clientData); +static int convertToSwitch(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + return convertToBoolean(interp, objPtr, pPtr, clientData); } -static int convertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToObject(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { if (GetObjectFromObj(interp, objPtr, (XOTclObject **)clientData) == TCL_OK) return TCL_OK; return XOTclObjErrType(interp, objPtr, "object"); } -static int convertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToClass(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { if (GetClassFromObj(interp, objPtr, (XOTclClass **)clientData, 0) == TCL_OK) { return TCL_OK; } return XOTclObjErrType(interp, objPtr, "class"); } -static int convertToRelation(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertToRelation(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { /* XOTclRelationCmd is the setter, which checks the values according to the relation type (Class, List of Class, list of filters; we treat it here just like a tclobj */ *clientData = (ClientData)objPtr; return TCL_OK; } -static int convertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientData) { +static int convertViaCmd(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { + Tcl_Obj *ov[4]; + int result; + + ov[0] = XOTclGlobalObjects[XOTE_PARAMETER_TYPE_OBJ]; + ov[1] = pPtr->arg; + ov[2] = pPtr->nameObj; + ov[3] = objPtr; + result = Tcl_EvalObjv(interp, 4, ov, 0); + if (result == TCL_OK) { + *clientData = (ClientData)objPtr; + } + return result; +} + +static int convertToObjpattern(Tcl_Interp *interp, Tcl_Obj *objPtr, XOTclParam CONST *pPtr, ClientData *clientData) { Tcl_Obj *patternObj = objPtr; char *pattern = ObjStr(objPtr); @@ -5660,7 +5707,27 @@ paramPtr->converter = convertToRelation; paramPtr->type = "tclobj"; } else { - fprintf(stderr, "**** unknown parameter option: def %s, option '%s' (%d)\n", paramPtr->name, option, length); + Tcl_Obj *checker = nonposargType(interp, option, length); + XOTclObject *paramObj; + XOTclClass *pcl; + Tcl_Command cmd; + int result; + + result = GetObjectFromObj(interp, XOTclGlobalObjects[XOTE_PARAMETER_TYPE_OBJ], ¶mObj); + if (result != TCL_OK) + return result; + + cmd = ObjectFindMethod(interp,paramObj, ObjStr(checker), &pcl); + + if (cmd == NULL) { + fprintf(stderr, "**** could not find checker method %s defined on %s\n", + ObjStr(checker), objectName(paramObj)); + } + + paramPtr->converter = convertViaCmd; + paramPtr->nrArgs = 1; + paramPtr->arg = checker; + /* TODO: free checker on paramsfree*/ } if ((paramPtr->flags & disallowedOptions)) { @@ -8584,25 +8651,14 @@ FREE(aliasCmdClientData, tcd); } -static int -XOTclDispatchCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { +static int +XOTclDispatchCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, + int withObjscope, int nobjc, Tcl_Obj *CONST nobjv[]) { int result; - char *method; - XOTclObject *obj; - register char *n; + register char *n = methodName + strlen(methodName); - if (objc < 3) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, " ?args?"); - } + /* TODO: test, handle withObjScope */ - GetObjectFromObj(interp, objv[2], &obj); - if (!obj) - return XOTclObjErrType(interp, objv[2], "Class|Object"); - - method = ObjStr(objv[1]); - n = method + strlen(method); - /*fprintf(stderr, "Dispatch obj=%s, o=%p cmd m='%s'\n",ObjStr(objv[2]),obj,method);*/ /* if the specified method is a fully qualified cmd name like e.g. @@ -8611,18 +8667,18 @@ it */ /*search for last '::'*/ - while ((*n != ':' || *(n-1) != ':') && n-1 > method) {n--; } - if (*n == ':' && n > method && *(n-1) == ':') {n--;} + while ((*n != ':' || *(n-1) != ':') && n-1 > methodName) {n--; } + if (*n == ':' && n > methodName && *(n-1) == ':') {n--;} - if ((n-method)>1 || *method == ':') { + if ((n-methodName)>1 || *methodName == ':') { Tcl_DString parentNSName, *dsp = &parentNSName; Tcl_Namespace *nsPtr; Tcl_Command cmd, importedCmd; char *parentName, *tail = n+2; DSTRING_INIT(dsp); - if (n-method != 0) { - Tcl_DStringAppend(dsp, method, (n-method)); + if (n-methodName != 0) { + Tcl_DStringAppend(dsp, methodName, (n-methodName)); parentName = Tcl_DStringValue(dsp); nsPtr = Tcl_FindNamespace(interp, parentName, (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); DSTRING_FREE(dsp); @@ -8631,7 +8687,7 @@ } if (!nsPtr) { return XOTclVarErrMsg(interp, "cannot lookup parent namespace '", - method, "'", (char *) NULL); + methodName, "'", (char *) NULL); } fprintf(stderr, " .... findmethod '%s' in %s\n",tail, nsPtr->fullName); cmd = FindMethod(nsPtr, tail); @@ -8644,27 +8700,29 @@ tail, "'", (char *) NULL); } - result = InvokeMethod((ClientData)obj, interp, - objc-2, objv+2, cmd, obj, + result = InvokeMethod((ClientData)object, interp, + nobjc, nobjv, cmd, object, NULL /*XOTclClass *cl*/, tail, XOTCL_CSC_TYPE_PLAIN); } else { /* no colons, use method from dispatch order, with filters etc. - strictly speaking unneccessary, but can be used to invoke protected methods */ - int nobjc; + + /* TODO: adjust objv, objc, wont't be correct after switch to parameter interface */ + int objc; Tcl_Obj *arg; - Tcl_Obj *CONST *nobjv; + Tcl_Obj *CONST *objv; - if (objc >= 3) { - arg = objv[3]; - nobjv = objv + 2; + if (nobjc >= 3) { + arg = nobjv[3]; + objv = nobjv + 2; } else { arg = NULL; - nobjv = NULL; + objv = NULL; } - nobjc = objc-3; - result = XOTclCallMethodWithArgs((ClientData)obj, interp, objv[1], arg, - nobjc, nobjv, XOTCL_CM_NO_UNKNOWN); + objc = nobjc-3; + result = XOTclCallMethodWithArgs((ClientData)object, interp, nobjv[1], arg, + objc, objv, XOTCL_CM_NO_UNKNOWN); } return result; } @@ -8955,7 +9013,7 @@ /* Check the default value, unless we have an INITCMD */ if ((pPtr->flags & XOTCL_ARG_INITCMD) == 0) { - if ((*pPtr->converter)(interp, newValue, &checkedData) != TCL_OK) { + if ((*pPtr->converter)(interp, newValue, pPtr, &checkedData) != TCL_OK) { return TCL_ERROR; } } @@ -8981,7 +9039,7 @@ XOTclObject *obj, Tcl_Obj *procNameObj, XOTclParam CONST *paramPtr, int nrParams, parseContext *pc) { - int i, o, flagCount = 0, nrReq = 0, nrOpt = 0, dashdash = 0; + int i, o, flagCount = 0, nrReq = 0, nrOpt = 0, dashdash = 0, nrDashdash = 0; /* todo benchmark with and without CONST */ XOTclParam CONST *pPtr; @@ -8999,17 +9057,18 @@ pPtr->name,pPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); #endif if (*pPtr->name == '-') { + int p, found; + char *objStr; /* Handle non-positional (named) parameters, starting with a * "-"; arguments can be given in an arbitrary order */ - int p, found; - char *objStr; for (p = o; pname && *nppPtr->name == '-'; nppPtr ++) { if (strcmp(objStr,nppPtr->name) == 0) { @@ -9028,7 +9087,7 @@ nppPtr-paramPtr, nppPtr->name, ObjStr(objv[p]), nppPtr->nrArgs, nppPtr->flags & XOTCL_ARG_REQUIRED ? "req":"not req"); #endif - if ((*nppPtr->converter)(interp, objv[p], &pc->clientData[nppPtr-paramPtr]) != TCL_OK) { + if ((*nppPtr->converter)(interp, objv[p], nppPtr, &pc->clientData[nppPtr-paramPtr]) != TCL_OK) { return TCL_ERROR; } pc->objv[nppPtr-paramPtr] = objv[p]; @@ -9065,6 +9124,7 @@ fprintf(stderr, "... skip double dash once\n"); #endif dashdash++; + nrDashdash++; o++; } } @@ -9080,7 +9140,7 @@ if (pPtr->flags & XOTCL_ARG_REQUIRED) nrReq++; else nrOpt++; /*fprintf(stderr, "... arg %s req %d converter %p try to set on %d: '%s'\n", pPtr->name,pPtr->flags & XOTCL_ARG_REQUIRED,pPtr->converter,i, ObjStr(objv[o]));*/ - if ((*pPtr->converter)(interp, objv[o], &pc->clientData[i]) != TCL_OK) { + if ((*pPtr->converter)(interp, objv[o], pPtr, &pc->clientData[i]) != TCL_OK) { return TCL_ERROR; } @@ -9114,7 +9174,7 @@ if (pc->lastobjc < nrReq) { return ArgumentError(interp, "not enough arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ } - if (!pc->varArgs && objc-dashdash-1 > nrReq + nrOpt) { + if (!pc->varArgs && objc-nrDashdash-1 > nrReq + nrOpt) { return ArgumentError(interp, "to many arguments:", paramPtr, NULL, procNameObj); /* for methods and cmds */ } @@ -9372,7 +9432,7 @@ char *patternString = NULL; int rc; - if (pattern && convertToObjpattern(interp, pattern, (ClientData *)&patternObj) == TCL_OK) { + if (pattern && convertToObjpattern(interp, pattern, NULL, (ClientData *)&patternObj) == TCL_OK) { if (getMatchObject(interp, patternObj, pattern, &matchObject, &patternString) == -1) { if (patternObj) { DECR_REF_COUNT(patternObj); @@ -9529,6 +9589,7 @@ /*fprintf(stderr, "registering an object %p\n",tcd);*/ XOTclObjectRefCountIncr((XOTclObject *)tcd); } + /* TODO: check aliases for procs, problem when proc is deleted */ if (withProtected) { flags = XOTCL_CMD_PROTECTED_METHOD; @@ -10107,10 +10168,9 @@ /* special setter due to relation handling */ if (paramPtr->converter == convertToRelation) { int relIdx; - result = convertToRelationtype(interp, paramPtr->nameObj, (ClientData)&relIdx); + result = convertToRelationtype(interp, paramPtr->nameObj, paramPtr, (ClientData)&relIdx); if (result == TCL_OK) { result = XOTclRelationCmd(interp, obj, relIdx, newValue); - /*fprintf(stderr, " relationcmd %s %d '%s' returned (%d)\n", objectName(obj), relIdx, ObjStr(newValue), result);*/ } if (result != TCL_OK) { XOTcl_PopFrame(interp, obj); @@ -10456,30 +10516,10 @@ static int XOTclOProcSearchMethod(Tcl_Interp *interp, XOTclObject *obj, char *name) { XOTclClass *pcl = NULL; - Tcl_Command cmd = NULL; + Tcl_Command cmd = ObjectFindMethod(interp, obj, name, &pcl); Tcl_ResetResult(interp); - if (!(obj->flags & XOTCL_MIXIN_ORDER_VALID)) - MixinComputeDefined(interp, obj); - - if (obj->flags & XOTCL_MIXIN_ORDER_DEFINED_AND_VALID) { - XOTclCmdList *mixinList; - for (mixinList = obj->mixinOrder; mixinList; mixinList = mixinList->nextPtr) { - XOTclClass *mcl = XOTclpGetClass(interp, (char *)Tcl_GetCommandName(interp, mixinList->cmdPtr)); - if (mcl && (pcl = SearchCMethod(mcl, name, &cmd))) { - break; - } - } - } - - if (!cmd && obj->nsPtr) { - cmd = FindMethod(obj->nsPtr, name); - } - - if (!cmd && obj->cl) - pcl = SearchCMethod(obj->cl, name, &cmd); - if (cmd) { XOTclObject *pobj = pcl ? NULL : obj; char *simpleName = (char *)Tcl_GetCommandName(interp, cmd); @@ -10493,6 +10533,10 @@ return TCL_OK; } +static int XOTclOSetMethod(Tcl_Interp *interp, XOTclObject *object, Tcl_Obj *variable, Tcl_Obj *value) { + return setInstVar(interp, object, variable, value); +} + static int XOTclOSetvaluesMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]) { Tcl_Obj **argv, **nextArgv, *resultObj; int i, argc, nextArgc, normalArgs, result = TCL_OK, isdasharg = NO_DASH; @@ -12613,7 +12657,6 @@ Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); /*Tcl_CreateObjCommand(interp, "::xotcl::K", XOTclKObjCmd, 0, 0);*/ - Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); #if defined(PRE85) # ifdef XOTCL_BYTECODE instructions[INST_INITPROC].cmdPtr = (Command *) Index: generic/xotclInt.h =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- generic/xotclInt.h (.../xotclInt.h) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ generic/xotclInt.h (.../xotclInt.h) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -451,17 +451,19 @@ /* * object and class internals */ +struct XOTclParam; +typedef int (XOTclTypeConverter)(Tcl_Interp *interp, Tcl_Obj *obj, + struct XOTclParam CONST *pPtr, ClientData *clientData); -typedef int (XOTclTypeConverter) _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *obj, ClientData *clientData)); - -typedef struct { +typedef struct XOTclParam { char *name; int flags; int nrArgs; XOTclTypeConverter *converter; Tcl_Obj *defaultValue; char *type; Tcl_Obj *nameObj; + Tcl_Obj *arg; } XOTclParam; typedef struct XOTclParamDefs { @@ -550,7 +552,7 @@ XOTE_ZERO, XOTE_ONE, XOTE_MOVE, XOTE_SELF, XOTE_CLASS, XOTE_RECREATE, XOTE_SELF_CLASS, XOTE_SELF_PROC, XOTE_EXIT_HANDLER, XOTE_DEFAULTSUPERCLASS, XOTE_DEFAULTMETACLASS, - XOTE_NON_POS_ARGS_OBJ, XOTE_SETVALUES, + XOTE_PARAMETER_TYPE_OBJ, XOTE_SETVALUES, XOTE_CLEANUP, XOTE_CONFIGURE, XOTE_FILTER, XOTE_INSTFILTER, XOTE_INSTPROC, XOTE_PROC, XOTE_INSTFORWARD, XOTE_FORWARD, XOTE_INSTCMD, XOTE_CMD, XOTE_INSTPARAMETERCMD, XOTE_PARAMETERCMD, @@ -571,7 +573,7 @@ "0", "1", "move", "self", "class", "recreate", "self class", "self proc", "__exitHandler", "__default_superclass", "__default_metaclass", - "::xotcl::nonposArgs", "setvalues", + "::xotcl::parameterType", "setvalues", "cleanup", "configure", "filter", "instfilter", "instproc", "proc", "instforward", "forward", "instcmd", "cmd", "instparametercmd", "parametercmd", Index: tests/objparametertest.xotcl =================================================================== diff -u -r6c7f27084c9ec8964db4fb29623fa956aaf65999 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- tests/objparametertest.xotcl (.../objparametertest.xotcl) (revision 6c7f27084c9ec8964db4fb29623fa956aaf65999) +++ tests/objparametertest.xotcl (.../objparametertest.xotcl) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -258,6 +258,31 @@ # "xxx" \ # "query instparams for info method 'params' method" +::xotcl::parameterType proc type=mytype {name value} { + if {$value < 1 || $value > 3} { + error "Value '$value' of parameter $name is not between 1 and 3" + } +} + +D instproc foo {a:mytype} { + puts stderr a=$a +} +d1 foo 1 + +catch {d1 foo 10} errorMsg +? {set ::errorMsg} \ + "Value '10' of parameter a is not between 1 and 3" \ + "invalid value" + +D instproc foo {a:unknowntype} { + puts stderr a=$a +} + +catch {d1 foo 10} errorMsg +? {set ::errorMsg} \ + "::xotcl::parameterType: unable to dispatch method 'type=unknowntype'" \ + "missing type checker" + ## TODO regression test for type checking, parameter options (initcmd, ## substdefault, combinations with defaults, ...), etc. Index: tests/testx.xotcl =================================================================== diff -u -rbedcf64642123d38ace4f5117e2b4b99fe9a0e06 -r2ce14fba0764a9fcbbe7cc2f582472526a58ddf0 --- tests/testx.xotcl (.../testx.xotcl) (revision bedcf64642123d38ace4f5117e2b4b99fe9a0e06) +++ tests/testx.xotcl (.../testx.xotcl) (revision 2ce14fba0764a9fcbbe7cc2f582472526a58ddf0) @@ -996,28 +996,29 @@ TestX filterSimpleObserver -proc run {{n 20}} { set ::filterCount 0 for {set i 0} {$i < $n} {incr i} { - Class NetAccess$i + set ::filterResult [list] + Class NetAccess$i Class Http$i -superclass NetAccess$i Class TransferDialog$i TransferDialog$i proc addObserver cl { $cl instproc observerFilter args { - set calledMethod [self calledproc] - set callingClass [my info class] - incr ::filterCount - set result [next] - - my set r 34 - - foreach var {args calledMethod callingClass result} { - if {[info vars $var] != $var} { - puts stderr "[self] -- Simple Observer - info vars in filter" - exit - } + set calledMethod [self calledproc] + set callingClass [my info class] + incr ::filterCount + set result [next] + + my set r 34 + + foreach var {args calledMethod callingClass result} { + if {[info vars $var] != $var} { + puts stderr "[self] -- Simple Observer - info vars in filter" + exit + } } - - - return [self]-[self class]-[my info class]-$args-[self calledproc]-[self callingproc]-$result + + lappend ::filterResult [self]-[self class]-[my info class]-$args-[self calledproc]-[self callingproc]-$result + return $result } $cl instfilter observerFilter } @@ -1074,11 +1075,12 @@ t($i) show $i Http$i h($i) -query q -path p -bu b - + set ::filterResult [list] set erg [h($i) GET 1] - ::errorCheck $erg "::h($i)-::NetAccess$i-::Http$i-1-GET-run-abc?q" \ + ::errorCheck $erg "abc?q" \ "Simple Observer - Filter Return" - + ::errorCheck $::filterResult "{::h($i)-::NetAccess$i-::Http$i-query url path-instvar-GET-} ::h($i)-::NetAccess$i-::Http$i-1-GET-run-abc?q" \ + "Simple Observer - Filter Return" } for {set i 0} {$i < $n} {incr i} { NetAccess$i instfilter {} @@ -1091,7 +1093,7 @@ TransferDialog$i destroy } - ::errorCheck $::filterCount 240 \ + ::errorCheck $::filterCount 260 \ "Simple Observer - Filter Count" } @@ -1313,11 +1315,11 @@ set r [anObject aProc] if {$i > 0} { ::errorCheck $InfoTraceResult \ - "{::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-cleanup aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-setvalues aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-recreate aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::ObjectsClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ + "{::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-cleanup aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-setvalues aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instparams, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-recreate aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instparams, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::ObjectsClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ "FilterInfo InfoTrace: Filter information wrong (b)" } else { ::errorCheck $InfoTraceResult \ - "{::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-alloc aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-setvalues aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::ObjectsClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ + "{::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instparams, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-alloc aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-setvalues aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-configure aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::aClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anotherObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {-::anotherObject-infoTraceFilter-::xotcl::Object ::aClass-init aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::xotcl::Class-::xotcl::classInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instparams, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars-class} info-::aClass {::xotcl::Class-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::aClass-infoTraceFilter-::xotcl::Object ::xotcl::Class-create aProc-::anObject {::ObjectsClass-::xotcl::Object instfilter infoTraceFilter}} {::ObjectsClass-::xotcl::objectInfo-infoTraceFilter-::xotcl::Object {valid options are: args, body, check, children, class, commands, default, filter, filterguard, forward, hasnamespace, info, invar, is, methods, mixin, mixinguard, nonposargs, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, vars-class} info-::anObject {::xotcl::Object-::xotcl::Object instfilter infoTraceFilter}} {::anotherObject-::anObject-infoTraceFilter-::xotcl::Object ::ObjectsClass-aProc run-::filterInfo {-::xotcl::Object instfilter infoTraceFilter}}" \ "FilterInfo InfoTrace: Filter information wrong" } } @@ -2833,7 +2835,7 @@ Recreated recreateObj recreateObj destroy errorCheck [set ::recreateFilterResult] \ - " ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->setvalues ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->cleanup ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->setvalues ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->destroy" \ + " ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->objectparameter ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->cleanup ::recreateObj+::xotcl::Object->configure ::recreateObj+::xotcl::Object->init ::recreateObj+::xotcl::Object->destroy" \ "recreateObj - recreateFilterResult" if {$i == 0} { errorCheck [set ::recreateMixinResult] \ @@ -3058,16 +3060,16 @@ ::errorCheck [b info procs] objproc "info procs" ::errorCheck [B info instprocs] myProc2 "info instprocs" - ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info infoTraceFilter init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objproc parametercmd proc procsearch requireNamespace self set setFilter setvalues signature subst trace unset uplevel upvar volatile vwait" "b info methods" + ::errorCheck [lsort [b info methods]] "__next abstract append array autoname check class cleanup configure contains copy defaultmethod destroy eval exists extractConfigureArg f filter filterguard filtersearch forward hasclass incr info init instvar invar isclass ismetaclass ismixin isobject istype lappend method mixin mixinguard move myProc myProc2 myProcMix1 myProcMix2 noinit objectparameter objproc parametercmd proc procsearch requireNamespace self set setFilter setvalues signature subst trace unset uplevel upvar volatile vwait" "b info methods" - ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move myProc myProc2 myProcMix1 myProcMix2 objproc self setFilter signature" "b info methods -nocmds" + ::errorCheck [lsort [b info methods -nocmds]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init method move myProc myProc2 myProcMix1 myProcMix2 objectparameter objproc self setFilter signature" "b info methods -nocmds" - ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinguard noinit objectparameter parametercmd proc procsearch requireNamespace set setvalues subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" - ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move myProc myProc2 objproc self setFilter signature" "b info methods -nocmds -nomixins" + ::errorCheck [lsort [b info methods -noprocs]] "__next append array autoname check class cleanup configure destroy eval exists filter filterguard filtersearch forward incr info instvar invar isclass ismetaclass ismixin isobject istype lappend mixin mixinguard noinit parametercmd proc procsearch requireNamespace set setvalues subst trace unset uplevel upvar volatile vwait" "b info methods -noprocs" + ::errorCheck [lsort [b info methods -nocmds -nomixins]] "abstract contains copy defaultmethod extractConfigureArg f hasclass init method move myProc myProc2 objectparameter objproc self setFilter signature" "b info methods -nocmds -nomixins" ::errorCheck [b info methods -nocmds -noprocs] "" "b info methods -nocmds -noprocs" - ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass infoTraceFilter init method move parameter self setFilter signature uses" "B info methods -nocmds" + ::errorCheck [lsort [B info methods -nocmds]] "abstract allinstances contains copy defaultmethod extractConfigureArg f hasclass init method move objectparameter parameter self setFilter signature uses" "B info methods -nocmds" namespace eval a { proc o args {return o} @@ -3292,7 +3294,7 @@ ::errorCheck [o mixin XY4] ::XY4 " __unknown XY4" } - ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars} "info info" + ::errorCheck [UnknownClass info info] {valid options are: args, body, check, children, class, classchildren, classparent, commands, default, filter, filterguard, forward, hasnamespace, heritage, info, instances, instargs, instbody, instcommands, instdefault, instfilter, instfilterguard, instforward, instinvar, instmixin, instmixinguard, instmixinof, instnonposargs, instparametercmd, instparams, instpost, instpre, instprocs, invar, is, methods, mixin, mixinguard, mixinof, nonposargs, parameter, parametercmd, params, parent, post, pre, precedence, procs, slotobjects, slots, subclass, superclass, vars} "info info" # clear unknown handler to avoid strange results later Class proc __unknown "" "" @@ -3899,19 +3901,19 @@ catch { o y 4 56 5 } m - errorCheck $m {wrong # args: should be "y ?-x arg? ?-a arg? a b"} "wrong \# check 1" + errorCheck $m {to many arguments: should be "y ?-x arg? ?-a arg? a b"} "wrong \# check 1" catch { o y } m - errorCheck $m {wrong # args: should be "y ?-x arg? ?-a arg? a b"} "wrong \# check 2" + errorCheck $m {not enough arguments: should be "y ?-x arg? ?-a arg? a b"} "wrong \# check 2" catch { o y -x 1 } m - errorCheck $m {method y: required argument 'a' is missing} "wrong \# check 3" + errorCheck $m {::o y: required argument 'a' is missing} "wrong \# check 3" catch { o z1 a 1 2 3 } m - errorCheck $m {method z1: required argument 'x' is missing} "required missing" + errorCheck $m {::o z1: required argument 'x' is missing} "required missing" errorCheck [o z1 -x 1 a 1 2 3] "1 -- 1 2 3" "invocation 1" errorCheck [o z2 -x 2 a 1 2 3] "2 -- a 1 2 3 -- 1 -- 1 2" "invocation 2" catch { @@ -3990,7 +3992,7 @@ oa foo "---" catch {oa foo "--"} msg - errorCheck $msg "method foo: required argument 'b' is missing" "Non-pos arg: double dash alone" + errorCheck $msg "::oa foo: required argument 'b' is missing" "Non-pos arg: double dash alone" Class C C create c1 @@ -4022,7 +4024,7 @@ "Defaults for instproc" catch {C info instdefault m2 xxx e} msg - errorCheck $msg "method 'm2' doesn't have an argument 'xxx'" \ + errorCheck $msg {procedure "info m2" doesn't have an argument "e"} \ "Defaults instproc error" C instproc m3 {