Start making TclOO faster to initialise (backport)

5 files changed, 89 insertions, 28 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 76e2016..09071e6 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -428,6 +428,10 @@ InitFoundation(
      * ensemble.
      */
 
+    CreateCmdInNS(interp, fPtr->helpersNs, "callback",
+	    TclOOCallbackObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "mymethod",
+	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
@@ -3144,6 +3148,30 @@ Tcl_GetObjectName(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOObjectMyName --
+ *
+ *	Utility function that returns the name of the object's [my], or NULL
+ *	if it has been deleted (or otherwise doesn't exist).
+ *
+ * ----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclOOObjectMyName(
+    Tcl_Interp *interp,
+    Object *oPtr)
+{
+    Tcl_Obj *namePtr;
+    if (!oPtr->myCommand) {
+	return NULL;
+    }
+    TclNewObj(namePtr);
+    Tcl_GetCommandFullName(interp, oPtr->myCommand, namePtr);
+    return namePtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * assorted trivial 'getter' functions
  *
  * ----------------------------------------------------------------------
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index f7bb969..092bc0d 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1373,6 +1373,65 @@ TclOOCopyObjectCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOCallbackObjCmd --
+ *
+ *	Implementation of the [callback] command, which constructs callbacks
+ *	into the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOCallbackObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+    CallContext *contextPtr;
+    Tcl_Obj *namePtr, *listPtr;
+
+    /*
+     * Start with sanity checks on the calling context to make sure that we
+     * are invoked from a suitable method context. If so, we can safely
+     * retrieve the handle to the object call context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"%s may only be called from inside a method",
+		TclGetString(objv[0])));
+	OO_ERROR(interp, CONTEXT_REQUIRED);
+	return TCL_ERROR;
+    }
+
+    contextPtr = (CallContext *) framePtr->clientData;
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "method ...");
+	return TCL_ERROR;
+    }
+
+    // Get the [my] real name.
+    namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
+    if (!namePtr) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"no possible safe callback without my", TCL_AUTO_LENGTH));
+	OO_ERROR(interp, NO_MY);
+	return TCL_ERROR;
+    }
+
+    // No check that the method exists; could be dynamically added.
+
+    listPtr = Tcl_NewListObj(1, &namePtr);
+    (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
+    Tcl_SetObjResult(interp, listPtr);
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index ec91971..4e7d4d0 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -513,6 +513,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOODefineObjSelfObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
@@ -608,6 +609,7 @@ MODULE_SCOPE int	TclNRObjectContextInvokeNext(Tcl_Interp *interp,
 MODULE_SCOPE void	TclOODefineBasicMethods(Class *clsPtr,
 			    const DeclaredClassMethod *dcm);
 MODULE_SCOPE Tcl_Obj *	TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
+MODULE_SCOPE Tcl_Obj *	TclOOObjectMyName(Tcl_Interp *interp, Object *oPtr);
 MODULE_SCOPE void	TclOOReleaseClassContents(Tcl_Interp *interp,
 			    Object *oPtr);
 MODULE_SCOPE int	TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 98fa20e..50d827f 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -30,14 +30,6 @@ static const char *tclOOSetupScript =
 "\t::namespace path {}\n"
 "\tnamespace eval Helpers {\n"
 "\t\tnamespace path {}\n"
-"\t\tproc callback {method args} {\n"
-"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
-"\t\t}\n"
-"\t\tnamespace export callback\n"
-"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
-"\t\tnamespace export -clear\n"
-"\t\trename tmp::callback mymethod\n"
-"\t\tnamespace delete tmp\n"
 "\t\tproc classvariable {name args} {\n"
 "\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
 "\t\t\tforeach v [list $name {*}$args] {\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2110861..cb77bb3 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -22,26 +22,6 @@
 
 	# ------------------------------------------------------------------
 	#
-	# callback, mymethod --
-	#
-	#	Create a script prefix that calls a method on the current
-	#	object. Same operation, two names.
-	#
-	# ------------------------------------------------------------------
-
-	proc callback {method args} {
-	    list [uplevel 1 {::namespace which my}] $method {*}$args
-	}
-
-	# Make the [callback] command appear as [mymethod] too.
-	namespace export callback
-	namespace eval tmp {namespace import ::oo::Helpers::callback}
-	namespace export -clear
-	rename tmp::callback mymethod
-	namespace delete tmp
-
-	# ------------------------------------------------------------------
-	#
 	# classvariable --
 	#
 	#	Link to a variable in the class of the current object.