Move [link] into C. (backport)

7 files changed, 131 insertions, 95 deletions

diff --git a/generic/tclInt.h b/generic/tclInt.h
index c227b0c..c450c80 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3318,6 +3318,10 @@ MODULE_SCOPE void	TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
 			    int loc);
 MODULE_SCOPE void	TclAdvanceLines(Tcl_Size *line, const char *start,
 			    const char *end);
+MODULE_SCOPE int	TclAliasCreate(Tcl_Interp *interp,
+			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
+			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
+			    Tcl_Obj *const objv[]);
 MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
 			    const unsigned char *bytes, Tcl_Size len);
 MODULE_SCOPE void	TclAppendUtfToUtf(Tcl_Obj *objPtr,
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 90af06e..5e54749 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -221,10 +221,6 @@ enum LimitHandlerFlags {
  * Prototypes for local static functions:
  */
 
-static int		AliasCreate(Tcl_Interp *interp,
-			    Tcl_Interp *childInterp, Tcl_Interp *parentInterp,
-			    Tcl_Obj *namePtr, Tcl_Obj *targetPtr, Tcl_Size objc,
-			    Tcl_Obj *const objv[]);
 static int		AliasDelete(Tcl_Interp *interp,
 			    Tcl_Interp *childInterp, Tcl_Obj *namePtr);
 static int		AliasDescribe(Tcl_Interp *interp,
@@ -701,7 +697,7 @@ NRInterpCmd(
 		return TCL_ERROR;
 	    }
 
-	    return AliasCreate(interp, childInterp, parentInterp, objv[3],
+	    return TclAliasCreate(interp, childInterp, parentInterp, objv[3],
 		    objv[5], objc - 6, objv + 6);
 	}
 
@@ -1232,7 +1228,7 @@ Tcl_CreateAlias(
     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
     Tcl_IncrRefCount(targetObjPtr);
 
-    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
 	    targetObjPtr, argc, objv);
 
     for (i = 0; i < argc; i++) {
@@ -1279,7 +1275,7 @@ Tcl_CreateAliasObj(
     targetObjPtr = Tcl_NewStringObj(targetCmd, -1);
     Tcl_IncrRefCount(targetObjPtr);
 
-    result = AliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
+    result = TclAliasCreate(childInterp, childInterp, targetInterp, childObjPtr,
 	    targetObjPtr, objc, objv);
 
     Tcl_DecrRefCount(childObjPtr);
@@ -1452,7 +1448,7 @@ TclPreventAliasLoop(
 /*
  *----------------------------------------------------------------------
  *
- * AliasCreate --
+ * TclAliasCreate --
  *
  *	Helper function to do the work to actually create an alias.
  *
@@ -1466,8 +1462,8 @@ TclPreventAliasLoop(
  *----------------------------------------------------------------------
  */
 
-static int
-AliasCreate(
+int
+TclAliasCreate(
     Tcl_Interp *interp,		/* Interp for error reporting. */
     Tcl_Interp *childInterp,	/* Interp where alias cmd will live or from
 				 * which alias will be deleted. */
@@ -2468,7 +2464,7 @@ ChildCreate(
 
 	TclNewLiteralStringObj(clockObj, "clock");
 	Tcl_IncrRefCount(clockObj);
-	status = AliasCreate(interp, childInterp, parentInterp, clockObj,
+	status = TclAliasCreate(interp, childInterp, parentInterp, clockObj,
 		clockObj, 0, NULL);
 	Tcl_DecrRefCount(clockObj);
 	if (status != TCL_OK) {
@@ -2558,7 +2554,7 @@ NRChildCmd(
 		    return AliasDelete(interp, childInterp, objv[2]);
 		}
 	    } else {
-		return AliasCreate(interp, childInterp, interp, objv[2],
+		return TclAliasCreate(interp, childInterp, interp, objv[2],
 			objv[3], objc - 4, objv + 4);
 	    }
 	}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index e77934c..0f400e7 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -442,6 +442,8 @@ InitFoundation(
 	    TclOOCallbackObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "classvariable",
 	    TclOOClassVariableObjCmd, NULL, NULL, 0);
+    CreateCmdInNS(interp, fPtr->helpersNs, "link",
+	    TclOOLinkObjCmd, NULL, NULL, 0);
     CreateCmdInNS(interp, fPtr->helpersNs, "next",
 	    NULL, TclOONextObjCmd, TclCompileObjectNextCmd);
     CreateCmdInNS(interp, fPtr->helpersNs, "nextto",
@@ -814,6 +816,7 @@ AllocObject(
     oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass",
 	    oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr,
 	    MyClassDeleted);
+    oPtr->linkedCmdsList = NULL;
     return oPtr;
 }
 
@@ -857,7 +860,18 @@ MyDeleted(
 				 * squelched. */
 {
     Object *oPtr = (Object *) clientData;
+    Tcl_Size linkc, i;
+    Tcl_Obj **linkv, *link;
 
+    if (oPtr->linkedCmdsList) {
+	TclListObjGetElements(NULL, oPtr->linkedCmdsList, &linkc, &linkv);
+	for (i=0 ; i<linkc ; i++) {
+	    link = linkv[i];
+	    (void) Tcl_DeleteCommand(oPtr->fPtr->interp, TclGetString(link));
+	}
+	Tcl_DecrRefCount(oPtr->linkedCmdsList);
+	oPtr->linkedCmdsList = NULL;
+    }
     oPtr->myCommand = NULL;
 }
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 8655e16..740e2cb 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1023,6 +1023,102 @@ TclOO_Object_VarName(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOLinkObjCmd --
+ *
+ *	Implementation of the [link] command, that makes a command that
+ *	invokes a method on the current object. The name of the command and
+ *	the name of the method match by default. Note that this command is
+ *	only ever to be used inside the body of a procedure-like method,
+ *	and is typically intended for constructors.
+ *
+ * ----------------------------------------------------------------------
+ */
+int
+TclOOLinkObjCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    /* Set up common bits. */
+    CallFrame *framePtr = ((Interp *) interp)->varFramePtr;
+    CallContext *context;
+    Object *oPtr;
+    Tcl_Obj *myCmd, **linkv, *src, *dst;
+    Tcl_Size linkc;
+    const char *srcStr;
+    int i;
+
+    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;
+    }
+    context = (CallContext *) framePtr->clientData;
+    oPtr = context->oPtr;
+    if (!oPtr->myCommand) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"cannot link to non-existent callback handle"));
+	OO_ERROR(interp, MY_GONE);
+	return TCL_ERROR;
+    }
+    myCmd = Tcl_NewObj();
+    Tcl_GetCommandFullName(interp, oPtr->myCommand, myCmd);
+    if (!oPtr->linkedCmdsList) {
+	oPtr->linkedCmdsList = Tcl_NewListObj(0, NULL);
+	Tcl_IncrRefCount(oPtr->linkedCmdsList);
+    }
+
+    /* For each argument */
+    for (i=1; i<objc; i++) {
+	/* Parse as list of (one or) two items: source and destination names */
+	if (TclListObjGetElements(interp, objv[i], &linkc, &linkv) != TCL_OK) {
+	    Tcl_BounceRefCount(myCmd);
+	    return TCL_ERROR;
+	}
+	switch (linkc) {
+	case 1:
+	    /* Degenerate case */
+	    src = dst = linkv[0];
+	    break;
+	case 2:
+	    src = linkv[0];
+	    dst = linkv[1];
+	    break;
+	default:
+	    Tcl_BounceRefCount(myCmd);
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad link description; must only have one or two elements"));
+	    OO_ERROR(interp, CMDLINK_FORMAT);
+	    return TCL_ERROR;
+	}
+
+	/* Qualify the source if necessary */
+	srcStr = TclGetString(src);
+	if (srcStr[0] != ':' || srcStr[1] != ':') {
+	    src = Tcl_ObjPrintf("%s::%s",
+		    context->oPtr->namespacePtr->fullName, srcStr);
+	}
+
+	/* Make the alias command */
+	if (TclAliasCreate(interp, interp, interp, src, myCmd, 1, &dst) != TCL_OK) {
+	    Tcl_BounceRefCount(myCmd);
+	    Tcl_BounceRefCount(src);
+	    return TCL_ERROR;
+	}
+
+	/* Remember the alias for cleanup if necessary */
+	Tcl_ListObjAppendElement(NULL, oPtr->linkedCmdsList, src);
+    }
+    Tcl_BounceRefCount(myCmd);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * TclOONextObjCmd, TclOONextToObjCmd --
  *
  *	Implementation of the [next] and [nextto] commands. Note that these
@@ -1533,7 +1629,7 @@ TclOOCallbackObjCmd(
 	return TCL_ERROR;
     }
 
-    // Get the [my] real name.
+    /* Get the [my] real name. */
     namePtr = TclOOObjectMyName(interp, contextPtr->oPtr);
     if (!namePtr) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -1542,7 +1638,7 @@ TclOOCallbackObjCmd(
 	return TCL_ERROR;
     }
 
-    // No check that the method exists; could be dynamically added.
+    /* No check that the method exists; could be dynamically added. */
 
     listPtr = Tcl_NewListObj(1, &namePtr);
     (void) TclListObjAppendElements(NULL, listPtr, objc-1, objv+1);
@@ -1594,7 +1690,7 @@ TclOOClassVariableObjCmd(
 	return TCL_ERROR;
     }
 
-    // Get a reference to the class's namespace
+    /* Get a reference to the class's namespace */
     contextPtr = (CallContext *) framePtr->clientData;
     clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr;
     if (clsPtr == NULL) {
@@ -1605,7 +1701,7 @@ TclOOClassVariableObjCmd(
     }
     clsNsPtr = clsPtr->thisPtr->namespacePtr;
 
-    // Check the list of variable names
+    /* Check the list of variable names */
     for (i = 1; i < objc; i++) {
 	const char *varName = TclGetString(objv[i]);
 	if (Tcl_StringMatch(varName, "*(*)")) {
@@ -1624,10 +1720,10 @@ TclOOClassVariableObjCmd(
 	}
     }
 
-    // Lastly, link the caller's local variables to the class's variables
+    /* Lastly, link the caller's local variables to the class's variables */
     ourNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
     for (i = 1; i < objc; i++) {
-	// Locate the other variable.
+	/* Locate the other variable. */
 	iPtr->varFramePtr->nsPtr = (Namespace *) clsNsPtr;
 	otherPtr = TclObjLookupVarEx(interp, objv[i], NULL,
 		(TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
@@ -1637,7 +1733,7 @@ TclOOClassVariableObjCmd(
 	    return TCL_ERROR;
 	}
 
-	// Create the new variable and link it to otherPtr.
+	/* Create the new variable and link it to otherPtr. */
 	if (TclPtrObjMakeUpvarIdx(interp, otherPtr, objv[i], 0,
 		TCL_INDEX_NONE) != TCL_OK) {
 	    return TCL_ERROR;
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 4383b91..e7a3d1c 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -255,6 +255,7 @@ struct Object {
     PropertyStorage properties;	/* Information relating to the lists of
 				 * properties that this object *claims* to
 				 * support. */
+    Tcl_Obj *linkedCmdsList;	/* List of names of linked commands. */
 };
 
 enum ObjectFlags {
@@ -520,6 +521,7 @@ MODULE_SCOPE Tcl_ObjCmdProc	TclOOCallbackObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOClassVariableObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOCopyObjectCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOODelegateNameObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc	TclOOLinkObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOONextToObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc	TclOOSelfObjCmd;
diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h
index bd3721b..f7b023e 100644
--- a/generic/tclOOScript.h
+++ b/generic/tclOOScript.h
@@ -27,31 +27,6 @@
 static const char *tclOOSetupScript =
 /* !BEGIN!: Do not edit below this line. */
 "::namespace eval ::oo {\n"
-"\tproc Helpers::link {args} {\n"
-"\t\tset ns [uplevel 1 {::namespace current}]\n"
-"\t\tforeach link $args {\n"
-"\t\t\tif {[llength $link] == 2} {\n"
-"\t\t\t\tlassign $link src dst\n"
-"\t\t\t} elseif {[llength $link] == 1} {\n"
-"\t\t\t\tlassign $link src\n"
-"\t\t\t\tset dst $src\n"
-"\t\t\t} else {\n"
-"\t\t\t\treturn -code error -errorcode {TCL OO CMDLINK_FORMAT} \\\n"
-"\t\t\t\t\t\"bad link description; must only have one or two elements\"\n"
-"\t\t\t}\n"
-"\t\t\tif {![string match ::* $src]} {\n"
-"\t\t\t\tset src [string cat $ns :: $src]\n"
-"\t\t\t}\n"
-"\t\t\tinterp alias {} $src {} ${ns}::my $dst\n"
-"\t\t\ttrace add command ${ns}::my delete [list \\\n"
-"\t\t\t\t::oo::UnlinkLinkedCommand $src]\n"
-"\t\t}\n"
-"\t}\n"
-"\tproc UnlinkLinkedCommand {cmd args} {\n"
-"\t\tif {[namespace which $cmd] ne {}} {\n"
-"\t\t\trename $cmd {}\n"
-"\t\t}\n"
-"\t}\n"
 "\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
 "\t\tset originDelegate [DelegateName $originObject]\n"
 "\t\tset targetDelegate [DelegateName $targetObject]\n"
diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl
index 4509202..1564645 100644
--- a/tools/tclOOScript.tcl
+++ b/tools/tclOOScript.tcl
@@ -12,57 +12,6 @@
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 ::namespace eval ::oo {
-
-    #
-    # Commands that are made available to objects by default.
-    #
-
-    # ------------------------------------------------------------------
-    #
-    # link --
-    #
-    #	Make a command that invokes a method on the current object.
-    #	The name of the command and the name of the method match by
-    #	default.
-    #
-    # ------------------------------------------------------------------
-
-    proc Helpers::link {args} {
-	set ns [uplevel 1 {::namespace current}]
-	foreach link $args {
-	    if {[llength $link] == 2} {
-		lassign $link src dst
-	    } elseif {[llength $link] == 1} {
-		lassign $link src
-		set dst $src
-	    } else {
-		return -code error -errorcode {TCL OO CMDLINK_FORMAT} \
-		    "bad link description; must only have one or two elements"
-	    }
-	    if {![string match ::* $src]} {
-		set src [string cat $ns :: $src]
-	    }
-	    interp alias {} $src {} ${ns}::my $dst
-	    trace add command ${ns}::my delete [list \
-		::oo::UnlinkLinkedCommand $src]
-	}
-    }
-
-    # ----------------------------------------------------------------------
-    #
-    # UnlinkLinkedCommand --
-    #
-    #	Callback used to remove linked command when the underlying mechanism
-    #	that supports it is deleted.
-    #
-    # ----------------------------------------------------------------------
-
-    proc UnlinkLinkedCommand {cmd args} {
-	if {[namespace which $cmd] ne {}} {
-	    rename $cmd {}
-	}
-    }
-
     # ----------------------------------------------------------------------
     #
     # UpdateClassDelegatesAfterClone --