From 1e47aa3a2e2d85795e56613c97a47a6777e153d1 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 07:50:00 +0000 Subject: Move another definition (classmethod) into C. --- generic/tclOO.c | 1 + generic/tclOODefineCmds.c | 66 +++++++++++++++++++++++++++++++++++++++++++++++ generic/tclOOInt.h | 1 + generic/tclOOScript.h | 13 ---------- tools/tclOOScript.tcl | 28 -------------------- 5 files changed, 68 insertions(+), 41 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index 0ef69a4..3eeeb80 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 199fce7..40c4fe0 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -2228,6 +2228,72 @@ 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) +{ + if (objc != 2 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?args body?"); + return TCL_ERROR; + } + Class *clsPtr = TclOOGetClassDefineCmdContext(interp); + if (!clsPtr) { + return TCL_ERROR; + } + + int 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; + } + Tcl_Obj *forwardArgs[] = { + Tcl_NewStringObj("myclass", -1), + objv[1] + }; + Tcl_Obj *prefixObj = Tcl_NewListObj(2, forwardArgs); + Method *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 90d5069..7ea5999 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -500,6 +500,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 bd3721b..4a69bc8 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -66,19 +66,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 4509202..e480aac 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -90,34 +90,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 -- cgit v0.12