Move another command into C: classvariable

5 files changed, 94 insertions, 46 deletions

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1e8012f..4a2e35c 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -444,6 +444,8 @@ InitFoundation(
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "mymethod",
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "classvariable",
+	    TclOOClassVariableObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd, CMD_COMPILES_EXPANDED);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index aefa91d..866f080 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1412,6 +1412,97 @@ TclOOCallbackObjCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOOClassVariableObjCmd --
+ *
+ *	Implementation of the [classvariable] command, which links to
+ *	variables in the class of the current object.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOClassVariableObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name ...");
+	return TCL_ERROR;
+    }
+
+    /*
+     * 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;
+    }
+
+    // Get a reference to the class's namespace
+    CallContext *contextPtr = (CallContext *) framePtr->clientData;
+    Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
+    if (clsPtr == NULL) {
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
+		"method not defined by a class", TCL_AUTO_LENGTH));
+	OO_ERROR(interp, UNMATCHED_CONTEXT);
+	return TCL_ERROR;
+    }
+    Tcl_Namespace *clsNsPtr = clsPtr->thisPtr->namespacePtr;
+
+    // Check the list of variable names
+    for (int i = 1; i < objc; i++) {
+	const char *varName = TclGetString(objv[i]);
+	if (Tcl_StringMatch(varName, "*(*)")) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad variable name \"%s\": can't create a %s",
+		    varName, "scalar variable that looks like an array element"));
+	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+	    return TCL_ERROR;
+	}
+	if (Tcl_StringMatch(varName, "*::*")) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad variable name \"%s\": can't create a %s",
+		    varName, "local variable with a namespace separator in it"));
+	    Tcl_SetErrorCode(interp, "TCL", "UPVAR", "LOCAL_ELEMENT", NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    // Lastly, link the caller's local variables to the class's variables
+    Tcl_Namespace *ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
+    for (int i = 1; i < objc; i++) {
+	// Locate the other variable.
+	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
+	Var *arrayPtr, *otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
+		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
+		"access", /*createPart1*/ 1, /*createPart2*/ 0, &arrayPtr);
+	iPtr->varFramePtr->nsPtr = (Namespace *) ourNsPtr;
+	if (otherPtr == NULL) {
+	    return TCL_ERROR;
+	}
+
+	// Create the new variable and link it to otherPtr.
+	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0, -1) != TCL_OK) {
+	    return TCL_ERROR;
+	}
+    }
+
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 94eda61..0367e60 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -519,6 +519,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePrivateObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODefinePropertyCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOUnknownDefinition;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index 6b0c5bd..dcc44c0 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,23 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc Helpers::classvariable {name args} {\n"
-"\t\tset ns [info object namespace [uplevel 1 {self class}]]\n"
-"\t\tforeach v [list $name {*}$args] {\n"
-"\t\t\tif {[string match *(*) $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tif {[string match *::* $v]} {\n"
-"\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n"
-"\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n"
-"\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n"
-"\t\t\t}\n"
-"\t\t\tlappend vs $v $v\n"
-"\t\t}\n"
-"\t\ttailcall namespace upvar $ns {*}$vs\n"
-"\t}\n"
 "\tproc Helpers::link {args} {\n"
 "\t\tset ns [uplevel 1 {::namespace current}]\n"
 "\t\tforeach link $args {\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 2b9e2a4..3f34c56 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -19,35 +19,6 @@
 
     # ------------------------------------------------------------------
     #
-    # classvariable --
-    #
-    #	Link to a variable in the class of the current object.
-    #
-    # ------------------------------------------------------------------
-
-    proc Helpers::classvariable {name args} {
-	# Get a reference to the class's namespace
-	set ns [info object namespace [uplevel 1 {self class}]]
-	# Double up the list of variable names
-	foreach v [list $name {*}$args] {
-	    if {[string match *(*) $v]} {
-		set reason "can't create a scalar variable that looks like an array element"
-		return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    if {[string match *::* $v]} {
-		set reason "can't create a local variable with a namespace separator in it"
-		return -code error -errorcode {TCL UPVAR INVERTED} \
-		    [format {bad variable name "%s": %s} $v $reason]
-	    }
-	    lappend vs $v $v
-	}
-	# Lastly, link the caller's local variables to the class's variables
-	tailcall namespace upvar $ns {*}$vs
-    }
-
-    # ------------------------------------------------------------------
-    #
     # link --
     #
     #	Make a command that invokes a method on the current object.