diff options
| -rw-r--r-- | generic/tclOO.c | 1 | ||||
| -rw-r--r-- | generic/tclOODefineCmds.c | 69 | ||||
| -rw-r--r-- | generic/tclOOInt.h | 1 | ||||
| -rw-r--r-- | generic/tclOOScript.h | 13 | ||||
| -rw-r--r-- | tools/tclOOScript.tcl | 28 |
5 files changed, 71 insertions, 41 deletions
diff --git a/generic/tclOO.c b/generic/tclOO.c index 0f400e7..ba770f4 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -25,6 +25,7 @@ static const struct { Tcl_ObjCmdProc *objProc; int flag; } defineCmds[] = { + {"classmethod", TclOODefineClassMethodObjCmd, 0}, {"constructor", TclOODefineConstructorObjCmd, 0}, {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index d9a637a..ab6b398 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2228,6 +2228,75 @@ TclOODefineMethodObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineClassMethodObjCmd -- + * + * Implementation of the "classmethod" subcommand of the "oo::define" + * command. Defines a class method. See define(n) for details. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineClassMethodObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Class *clsPtr; + int isPublic; + Tcl_Obj *forwardArgs[2], *prefixObj; + Method *mPtr; + + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); + return TCL_ERROR; + } + clsPtr = TclOOGetClassDefineCmdContext(interp); + if (!clsPtr) { + return TCL_ERROR; + } + + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; + + // Create the method on the delegate class if the caller gave arguments and body + if (objc == 4) { + Tcl_Obj *delegateName = Tcl_ObjPrintf("%s:: oo ::delegate", + clsPtr->thisPtr->namespacePtr->fullName); + Class *delegatePtr = TclOOGetClassFromObj(interp, delegateName); + + Tcl_DecrRefCount(delegateName); + if (!delegatePtr) { + return TCL_ERROR; + } + if (IsPrivateDefine(interp)) { + isPublic = 0; + } + if (TclOONewProcMethod(interp, delegatePtr, isPublic, objv[1], + objv[2], objv[3], NULL) == NULL) { + return TCL_ERROR; + } + } + + // Make the connection to the delegate by forwarding + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } + forwardArgs[0] = Tcl_NewStringObj("myclass", -1); + forwardArgs[1] = objv[1]; + prefixObj = Tcl_NewListObj(2, forwardArgs); + mPtr = TclOONewForwardMethod(interp, clsPtr, isPublic, objv[1], prefixObj); + if (mPtr == NULL) { + Tcl_DecrRefCount(prefixObj); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineRenameMethodObjCmd -- * * Implementation of the "renamemethod" subcommand of the "oo::define" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index e7a3d1c..70b4a32 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -501,6 +501,7 @@ struct DeclaredClassMethod { MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclOODefineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOOObjDefObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOODefineClassMethodObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineConstructorObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDefnNsObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclOODefineDeleteMethodObjCmd; diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index f7b023e..79379d3 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -41,19 +41,6 @@ static const char *tclOOSetupScript = "\t\t\t\t}]\n" "\t\t}\n" "\t}\n" -"\tproc define::classmethod {name args} {\n" -"\t\t::set argc [::llength [::info level 0]]\n" -"\t\t::if {$argc == 3} {\n" -"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" -"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" -"\t\t\t\t[::lindex [::info level 0] 0]]\n" -"\t\t}\n" -"\t\t::set cls [::uplevel 1 self]\n" -"\t\t::if {$argc == 4} {\n" -"\t\t\t::oo::define [::oo::DelegateName $cls] method $name {*}$args\n" -"\t\t}\n" -"\t\t::tailcall forward $name myclass $name\n" -"\t}\n" "\tdefine Slot forward --default-operation my -append\n" "\tdefine Slot unexport destroy\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 1564645..8bb214a 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -39,34 +39,6 @@ # ---------------------------------------------------------------------- # - # oo::define::classmethod -- - # - # Defines a class method. See define(n) for details. - # - # Note that the ::oo::define namespace is semi-public and a bit weird - # anyway, so we don't regard the namespace path as being under control: - # fully qualified names are used for everything. - # - # ---------------------------------------------------------------------- - - proc define::classmethod {name args} { - # Create the method on the class if the caller gave arguments and body - ::set argc [::llength [::info level 0]] - ::if {$argc == 3} { - ::return -code error -errorcode {TCL WRONGARGS} [::format \ - {wrong # args: should be "%s name ?args body?"} \ - [::lindex [::info level 0] 0]] - } - ::set cls [::uplevel 1 self] - ::if {$argc == 4} { - ::oo::define [::oo::DelegateName $cls] method $name {*}$args - } - # Make the connection by forwarding - ::tailcall forward $name myclass $name - } - - # ---------------------------------------------------------------------- - # # Slot -- # # The class of slot operations, which are basically lists at the low |