Index: ChangeLog =================================================================== diff -u -r0e6f9ba5d9d7a8ce3e765f8a456a169f4b676b06 -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 --- ChangeLog (.../ChangeLog) (revision 0e6f9ba5d9d7a8ce3e765f8a456a169f4b676b06) +++ ChangeLog (.../ChangeLog) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) @@ -62,10 +62,13 @@ Meta C -superclass O -parameter {a {b -default ""} {c -default 1}} C c1 ;# c1 has no no default value for "a", before it had one ====== + 2009-07-04 - removed compatibility for versions before Tcl 8.4 (was not tested anyhow) This version requires at least Tcl 8.4. - - from 15356 generic/xotcl.c => 13346 + - support for generating interface for ::xotcl commands + - generated interface for ::xotcl::alias + - from 15356 generic/xotcl.c => 13313 2009-07-01 - moved all definitions of method commands to generated code Index: generic/gentclAPI.decls =================================================================== diff -u -ree73265e036871a0e6f5b83544ff0982c24864ed -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 --- generic/gentclAPI.decls (.../gentclAPI.decls) (revision ee73265e036871a0e6f5b83544ff0982c24864ed) +++ generic/gentclAPI.decls (.../gentclAPI.decls) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) @@ -5,14 +5,26 @@ # namespaces for types of methods array set ns { - objectMethod "::xotcl::cmd::Object" - classMethod "::xotcl::cmd::Class" - checkMethod "::xotcl::cmd::NonposArgs" - infoClassMethod "::xotcl::cmd::ClassInfo" - infoObjectMethod "::xotcl::cmd::ObjectInfo" + xotclCmd "::xotcl" + objectMethod "::xotcl::cmd::Object" + classMethod "::xotcl::cmd::Class" + checkMethod "::xotcl::cmd::NonposArgs" + infoClassMethod "::xotcl::cmd::ClassInfo" + infoObjectMethod "::xotcl::cmd::ObjectInfo" } # +# XOTcl commands +# +xotclCmd alias XOTclAliasCmd { + {-argName "object" -required 1 -type object} + {-argName "methodName" -required 1} + {-argName "-objscope"} + {-argName "-per-object"} + {-argName "-protected"} + {-argName "cmdName" -required 1 -type tclobj} +} +# # object methods # objectMethod autoname XOTclOAutonameMethod { Index: generic/gentclAPI.tcl =================================================================== diff -u -ree73265e036871a0e6f5b83544ff0982c24864ed -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 --- generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision ee73265e036871a0e6f5b83544ff0982c24864ed) +++ generic/gentclAPI.tcl (.../gentclAPI.tcl) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) @@ -54,7 +54,8 @@ array set "" $argDefinition set ifSet 0 set cVar 1 - if {[regexp {^-(.*)$} $(-argName) _ switchName]} { + set (-argName) [string map [list - _] $(-argName)] + if {[regexp {^_(.*)$} $(-argName) _ switchName]} { set varName with[string totitle $switchName] set calledArg $varName set type "int " @@ -176,10 +177,13 @@ } set namespaces [list] - foreach {key value} [array get ::ns] { lappend namespaces "\"$value\"" } + foreach {key value} [array get ::ns] { + # no need to create the ::xotcl namespace + if {$value eq "::xotcl"} continue + lappend namespaces "\"$value\"" + } set namespaceString [join $namespaces ",\n "] puts "char *method_command_namespace_names\[\] = {\n $namespaceString\n};" - puts $stubDecls puts $decls set enumString [join $enums ",\n "] @@ -225,6 +229,9 @@ proc objectMethod {methodName implementation argDefinitions} { methodDefinition $methodName objectMethod $implementation $argDefinitions } +proc xotclCmd {methodName implementation argDefinitions} { + methodDefinition $methodName xotclCmd $implementation $argDefinitions +} source [file dirname [info script]]/gentclAPI.decls Index: generic/tclAPI.h =================================================================== diff -u -r2252fd2633d5547530210a14fe47ff471b2cdbea -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 --- generic/tclAPI.h (.../tclAPI.h) (revision 2252fd2633d5547530210a14fe47ff471b2cdbea) +++ generic/tclAPI.h (.../tclAPI.h) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) @@ -109,6 +109,7 @@ static int XOTclOUpvarMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVolatileMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclOVwaitMethodStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); +static int XOTclAliasCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv []); static int XOTclCheckBooleanArgs(Tcl_Interp *interp, char *name, Tcl_Obj *value); static int XOTclCheckRequiredArgs(Tcl_Interp *interp, char *name, Tcl_Obj *value); @@ -201,6 +202,7 @@ static int XOTclOUpvarMethod(Tcl_Interp *interp, XOTclObject *obj, int objc, Tcl_Obj *CONST objv[]); static int XOTclOVolatileMethod(Tcl_Interp *interp, XOTclObject *obj); static int XOTclOVwaitMethod(Tcl_Interp *interp, XOTclObject *obj, char *varname); +static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName); enum { XOTclCheckBooleanArgsIdx, @@ -293,7 +295,8 @@ XOTclOUplevelMethodIdx, XOTclOUpvarMethodIdx, XOTclOVolatileMethodIdx, - XOTclOVwaitMethodIdx + XOTclOVwaitMethodIdx, + XOTclAliasCmdIdx } XOTclMethods; @@ -1794,6 +1797,25 @@ } } +static int +XOTclAliasCmdStub(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) { + parseContext pc; + + if (parseObjv(interp, objc, objv, XOTclAliasCmdIdx, &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]; + int withPer_object = (int )pc.clientData[3]; + int withProtected = (int )pc.clientData[4]; + Tcl_Obj *cmdName = (Tcl_Obj *)pc.clientData[5]; + + return XOTclAliasCmd(interp, object, methodName, withObjscope, withPer_object, withProtected, cmdName); + + } +} + static methodDefinition method_definitions[] = { {"::xotcl::cmd::NonposArgs::type=boolean", XOTclCheckBooleanArgsStub, { {"name", 1, 0, NULL}, @@ -2170,6 +2192,14 @@ }, {"::xotcl::cmd::Object::vwait", XOTclOVwaitMethodStub, { {"varname", 1, 0, NULL}} +}, +{"::xotcl::alias", XOTclAliasCmdStub, { + {"object", 1, 0, "object"}, + {"methodName", 1, 0, NULL}, + {"-objscope", 0, 0, NULL}, + {"-per-object", 0, 0, NULL}, + {"-protected", 0, 0, NULL}, + {"cmdName", 1, 0, "tclobj"}} } }; Index: generic/xotcl.c =================================================================== diff -u -r0e6f9ba5d9d7a8ce3e765f8a456a169f4b676b06 -r1b27a533f020bd0c0334abd6b2e1ba02db1eae71 --- generic/xotcl.c (.../xotcl.c) (revision 0e6f9ba5d9d7a8ce3e765f8a456a169f4b676b06) +++ generic/xotcl.c (.../xotcl.c) (revision 1b27a533f020bd0c0334abd6b2e1ba02db1eae71) @@ -9195,87 +9195,55 @@ return result; } -static int -XOTclAliasCmd(ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) { - XOTclObject *obj = NULL; - XOTclClass *cl = NULL; - Tcl_Command cmd = NULL, importedCmd, newCmd; +static int XOTclAliasCmd(Tcl_Interp *interp, XOTclObject *object, char *methodName, + int withObjscope, int withPer_object, int withProtected, Tcl_Obj *cmdName) { + XOTclClass *cl; + Tcl_Command cmd, importedCmd; Tcl_ObjCmdProc *objProc; - char allocation, *methodName, *optionName; + char allocation; Tcl_CmdDeleteProc *dp = NULL; aliasCmdClientData *tcd = NULL; - int objscope = 0, protected = 0, flags = 0, i; + int flags = 0; - if (objc < 4 || objc > 6) { - return XOTclObjErrArgCnt(interp, objv[0], NULL, - "| ?-objscope? ?-per-object? "); - } - - GetXOTclClassFromObj(interp, objv[1], &cl, 0); /* maybe provide base? */ - if (!cl) { - XOTclObjConvertObject(interp, objv[1], &obj); - if (!obj) - return XOTclObjErrType(interp, objv[1], "Class|Object"); - allocation = 'o'; - } else { + if (XOTclObjectIsClass(object)) { + cl = (XOTclClass *)object; allocation = 'c'; + } else { + cl = NULL; + allocation = 'o'; } - - methodName = ObjStr(objv[2]); - - for (i=3; i<6 && i < objc; i++) { - optionName = ObjStr(objv[i]); - if (*optionName != '-') break; - if (!strcmp("-objscope", optionName)) { - objscope = 1; - } else if (!strcmp("-per-object", optionName)) { - allocation = 'o'; - } else if (!strcmp("-protected", optionName)) { - protected = 1; - } else { - return XOTclErrBadVal(interp, "::xotcl::alias", - "option -objscope or -per-object", optionName); - } - } - - cmd = Tcl_GetCommandFromObj(interp, objv[i]); + cmd = Tcl_GetCommandFromObj(interp, cmdName); if (cmd == NULL) return XOTclVarErrMsg(interp, "cannot lookup command '", - ObjStr(objv[i]), "'", (char *) NULL); + ObjStr(cmdName), "'", (char *) NULL); if ((importedCmd = TclGetOriginalCommand(cmd))) { cmd = importedCmd; } objProc = Tcl_Command_objProc(cmd); - if (objc>i+1) { - return XOTclVarErrMsg(interp, "invalid argument '", - ObjStr(objv[i+1]), "'", (char *) NULL); - } - - if (objscope) { + if (withObjscope) { tcd = NEW(aliasCmdClientData); - tcd->cmdName = NULL; - tcd->obj = allocation == 'c' ? &cl->object : obj; - tcd->objProc = objProc; - tcd->clientData = Tcl_Command_objClientData(cmd); - objProc = XOTclObjscopedMethod; + tcd->cmdName = NULL; + tcd->obj = allocation == 'c' ? &cl->object : object; + tcd->objProc = objProc; + tcd->clientData = Tcl_Command_objClientData(cmd); + objProc = XOTclObjscopedMethod; dp = aliasCmdDeleteProc; } else { tcd = Tcl_Command_objClientData(cmd); } - if (protected) { + if (withProtected) { flags = XOTCL_PROTECTED_METHOD; } if (allocation == 'c') { - newCmd = XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, - objProc, tcd, dp, flags); + XOTclAddInstanceMethod(interp, (XOTcl_Class*)cl, methodName, + objProc, tcd, dp, flags); } else { - newCmd = XOTclAddObjectMethod(interp, (XOTcl_Object*)obj, methodName, - objProc, tcd, dp, flags); + XOTclAddObjectMethod(interp, (XOTcl_Object*)object, methodName, + objProc, tcd, dp, flags); } return TCL_OK; } @@ -13261,7 +13229,6 @@ Tcl_CreateObjCommand(interp, "::xotcl::self", XOTclGetSelfObjCmd, 0, 0); /*Tcl_CreateObjCommand(interp, "::xotcl::K", XOTclKObjCmd, 0, 0);*/ - Tcl_CreateObjCommand(interp, "::xotcl::alias", XOTclAliasCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::createobjectsystem", XOTclCreateObjectSystemCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::dispatch", XOTclDispatchCmd, 0, 0); Tcl_CreateObjCommand(interp, "::xotcl::methodproperty", XOTclMethodPropertyCmd, 0, 0);