Add [info linkedname] introspection commandinfo_linkedname

6 files changed, 201 insertions, 37 deletions

diff --git a/doc/info.n b/doc/info.n
index c3a62c9..3a13c06 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -297,6 +297,11 @@ scripts are stored.
 This is actually the value of the \fBtcl_library\fR
 variable and may be changed by setting \fBtcl_library\fR.
 .TP
+\fBinfo linkedname \fIvarname\fR
+.
+\fIVarname\fR must be a link variable.
+Returns the name of the variable it is linked to.
+.TP
 \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR?
 .
 Returns the filename loaded as part of \fIpackage\fR. If \fIpackage\fR
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index a7a5f43..5fa62b3 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -175,6 +175,7 @@ static const EnsembleImplMap defaultInfoMap[] = {
     {"hostname",	   InfoHostnameCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
     {"level",		   InfoLevelCmd,	    TclCompileInfoLevelCmd, NULL, NULL, 0},
     {"library",		   InfoLibraryCmd,	    TclCompileBasic0ArgCmd, NULL, NULL, 0},
+    {"linkedname",	   TclInfoLinkedNameCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
     {"loaded",		   InfoLoadedCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
     {"locals",		   TclInfoLocalsCmd,	    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
     {"nameofexecutable",   InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index cfcdd26..e7b55e2 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4217,9 +4217,7 @@ TEBCresume(
 		goto gotError;
 	    }
 	    TclSetVarArray(varPtr);
-	    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
-	    TclInitVarHashTable(varPtr->value.tablePtr,
-		    TclGetVarNsPtr(varPtr));
+	    TclInitArrayHashTable(varPtr);
 #ifdef TCL_COMPILE_DEBUG
 	    TRACE_APPEND(("done\n"));
 	} else {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 725280c..9a30ca2 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -208,14 +208,15 @@ typedef struct NamespacePathEntry NamespacePathEntry;
 
 /*
  * Special hashtable for variables: this is just a Tcl_HashTable with an nsPtr
- * field added at the end: in this way variables can find their namespace
- * without having to copy a pointer in their struct: they can access it via
- * their hPtr->tablePtr.
+ * field and a Var field added at the end: in this way variables can find their
+ * namespace or related array variable (for array elements) without having to
+ * copy a pointer in their struct: they can access it via their hPtr->tablePtr.
  */
 
 typedef struct TclVarHashTable {
     Tcl_HashTable table;
     struct Namespace *nsPtr;
+    struct Var *arrayPtr;
 } TclVarHashTable;
 
 /*
@@ -850,6 +851,11 @@ typedef struct VarInHash {
 	? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \
 	: NULL)
 
+#define TclGetVarArrayPtr(varPtr) \
+    (TclIsVarInHash(varPtr) \
+	? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->arrayPtr \
+	: NULL)
+
 #define VarHashRefCount(varPtr) \
     ((VarInHash *) (varPtr))->refCount
 
@@ -3002,11 +3008,14 @@ MODULE_SCOPE int	TclInfoCoroutineCmd(ClientData dummy, Tcl_Interp *interp,
 MODULE_SCOPE Tcl_Obj *	TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr);
 MODULE_SCOPE int	TclInfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int	TclInfoLinkedNameCmd(ClientData dummy,
+			    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE int	TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE int	TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE void	TclInitAlloc(void);
+MODULE_SCOPE void	TclInitArrayHashTable(Var *arrayPtr);
 MODULE_SCOPE void	TclInitDbCkalloc(void);
 MODULE_SCOPE void	TclInitDoubleConversion(void);
 MODULE_SCOPE void	TclInitEmbeddedConfigurationInformation(
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1947c8d..c3f63f6 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -135,6 +135,7 @@ static const char *badNamespace =	"parent namespace doesn't exist";
 static const char *missingName =	"missing variable name";
 static const char *isArrayElement =
 	"name refers to an element in an array";
+static const char *needVarLink =	"variable isn't a link";
 
 /*
  * A test to see if we are in a call frame that has local variables. This is
@@ -199,6 +200,8 @@ static Var *		VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj);
 MODULE_SCOPE Var *	TclLookupSimpleVar(Tcl_Interp *interp,
 			    Tcl_Obj *varNamePtr, int flags, const int create,
 			    const char **errMsgPtr, int *indexPtr);
+MODULE_SCOPE int	TclGetVarName(Tcl_Interp *interp, Var *varPtr,
+			    Tcl_Obj *objPtr);
 
 static Tcl_DupInternalRepProc	DupLocalVarName;
 static Tcl_FreeInternalRepProc	FreeLocalVarName;
@@ -968,8 +971,6 @@ TclLookupArrayElement(
 {
     int isNew;
     Var *varPtr;
-    TclVarHashTable *tablePtr;
-    Namespace *nsPtr;
 
     /*
      * We're dealing with an array element. Make sure the variable is an array
@@ -1003,15 +1004,7 @@ TclLookupArrayElement(
 	}
 
 	TclSetVarArray(arrayPtr);
-	tablePtr = ckalloc(sizeof(TclVarHashTable));
-	arrayPtr->value.tablePtr = tablePtr;
-
-	if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
-	    nsPtr = TclGetVarNsPtr(arrayPtr);
-	} else {
-	    nsPtr = NULL;
-	}
-	TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr);
+	TclInitArrayHashTable(arrayPtr);
     } else if (!TclIsVarArray(arrayPtr)) {
 	if (flags & TCL_LEAVE_ERR_MSG) {
 	    TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray,
@@ -1048,6 +1041,72 @@ TclLookupArrayElement(
 /*
  *----------------------------------------------------------------------
  *
+ * TclGetVarName --
+ *
+ *	Appends the name of a Tcl variable to the objPtr object.
+ *
+ * Results:
+ *	Returns 1 if the variable name was found, 0 otherwise.
+ *
+ * Side effects:
+ *	If found, the variable's name is appended to the string
+ *	representation of objPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclGetVarName(Tcl_Interp *interp, Var *varPtr, Tcl_Obj *objPtr)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *varFramePtr;
+    Tcl_Obj *objNamePtr;
+    int isElement;
+
+    if (TclIsVarInHash(varPtr)) {
+	if (TclIsVarDeadHash(varPtr)) {
+	    return 0;
+	}
+
+	isElement = TclIsVarArrayElement(varPtr);
+	if (isElement) {
+	    Var *arrayPtr = TclGetVarArrayPtr(varPtr);
+	    if (arrayPtr) {
+		TclGetVarName(interp, arrayPtr, objPtr);
+	    }
+	    Tcl_AppendToObj(objPtr, "(", 1);
+	}
+
+	objNamePtr = VarHashGetKey(varPtr);
+	Tcl_AppendObjToObj(objPtr, objNamePtr);
+
+	if (isElement) {
+	    Tcl_AppendToObj(objPtr, ")", 1);
+	}
+
+	return 1;
+    }
+
+    /* Find varPtr in compiled locals from current or upper call frames. */
+    for (varFramePtr = iPtr->varFramePtr;
+	    varFramePtr != NULL ;
+	    varFramePtr = varFramePtr->callerVarPtr) {
+
+	int index = varPtr - varFramePtr->compiledLocals;
+
+	if (index >= 0 && index < varFramePtr->numCompiledLocals) {
+	    objNamePtr = localName(varFramePtr, index);
+	    Tcl_AppendObjToObj(objPtr, objNamePtr);
+	    return 1;
+	}
+    }
+
+    return 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_GetVar --
  *
  *	Return the value of a Tcl variable as a string.
@@ -2825,8 +2884,7 @@ TclArraySet(
 	}
     }
     TclSetVarArray(varPtr);
-    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
-    TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
+    TclInitArrayHashTable(varPtr);
     return TCL_OK;
 }
 
@@ -4441,7 +4499,6 @@ Tcl_GetVariableFullName(
 {
     Interp *iPtr = (Interp *) interp;
     register Var *varPtr = (Var *) variable;
-    Tcl_Obj *namePtr;
     Namespace *nsPtr;
 
     if (!varPtr || TclIsVarArrayElement(varPtr)) {
@@ -4460,19 +4517,7 @@ Tcl_GetVariableFullName(
 	    Tcl_AppendToObj(objPtr, "::", 2);
 	}
     }
-    if (TclIsVarInHash(varPtr)) {
-	if (!TclIsVarDeadHash(varPtr)) {
-	    namePtr = VarHashGetKey(varPtr);
-	    Tcl_AppendObjToObj(objPtr, namePtr);
-	}
-    } else if (iPtr->varFramePtr->procPtr) {
-	int index = varPtr - iPtr->varFramePtr->compiledLocals;
-
-	if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) {
-	    namePtr = localName(iPtr->varFramePtr, index);
-	    Tcl_AppendObjToObj(objPtr, namePtr);
-	}
-    }
+    TclGetVarName(interp, varPtr, objPtr);
 }
 
 /*
@@ -5812,6 +5857,71 @@ TclInfoGlobalsCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclInfoLinkedNameCmd --
+ *
+ *	Called to implement the "info linkedname" command that returns the
+ *	name of a link variable. Handles the following syntax:
+ *
+ *	    info linkedname varname
+ *
+ * Results:
+ *	Returns TCL_OK if successful and TCL_ERROR if there is an error.
+ *
+ * Side effects:
+ *	Returns a result in the interpreter's result object. If there is an
+ *	error, the result is an error message.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInfoLinkedNameCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    Tcl_Obj *varName, *objNamePtr;
+    Var *varPtr;
+    const char *errMsg;
+    int index;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "varname");
+	return TCL_ERROR;
+    }
+
+    varName = objv[1];
+    varPtr = TclLookupSimpleVar(interp, varName, TCL_AVOID_RESOLVERS,
+	/* create */ 0, &errMsg, &index);
+
+    if (varPtr && !TclIsVarLink(varPtr)) {
+	errMsg = needVarLink;
+	varPtr = NULL;
+    }
+
+    if (varPtr == NULL) {
+	TclObjVarErrMsg(interp, varName, NULL, "access", errMsg, -1);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARLINK",
+	    TclGetString(varName), NULL);
+	return TCL_ERROR;
+    }
+
+    objNamePtr = Tcl_NewObj();
+    if (TclGetVarName(interp, varPtr->value.linkPtr, objNamePtr) != 1) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+	    "unable to find linked name for \"%s\"", TclGetString(varName)));
+	TclDecrRefCount(objNamePtr);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, objNamePtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclInfoLocalsCmd -- (moved over from tclCmdIl.c)
  *
  *	Called to implement the "info locals" command to return a list of
@@ -6015,6 +6125,22 @@ TclInitVarHashTable(
     Tcl_InitCustomHashTable(&tablePtr->table,
 	    TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
     tablePtr->nsPtr = nsPtr;
+    tablePtr->arrayPtr = NULL;
+}
+
+void
+TclInitArrayHashTable(
+    Var *arrayPtr)
+{
+    TclVarHashTable *tablePtr;
+
+    tablePtr = ckalloc(sizeof(TclVarHashTable));
+
+    Tcl_InitCustomHashTable(&tablePtr->table,
+	    TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType);
+    tablePtr->nsPtr = TclGetVarNsPtr(arrayPtr);
+    tablePtr->arrayPtr = arrayPtr;
+    arrayPtr->value.tablePtr = tablePtr;
 }
 
 static Tcl_HashEntry *
diff --git a/tests/info.test b/tests/info.test
index fd89b47..38b7887 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -678,16 +678,16 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body {
 } -result {wrong # args: should be "info subcommand ?arg ...?"}
 test info-21.2 {miscellaneous error conditions} -returnCodes error -body {
     info gorp
-} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "gorp": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, linkedname, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
 test info-21.3 {miscellaneous error conditions} -returnCodes error -body {
     info c
-} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "c": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, linkedname, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
 test info-21.4 {miscellaneous error conditions} -returnCodes error -body {
     info l
-} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "l": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, linkedname, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
 test info-21.5 {miscellaneous error conditions} -returnCodes error -body {
     info s
-} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
+} -result {unknown or ambiguous subcommand "s": must be args, body, class, cmdcount, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, linkedname, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
 
 ##
 # ### ### ### ######### ######### #########
@@ -2415,6 +2415,31 @@ test info-39.0 {Bug 4b61afd660} -setup {
     rename probe {}
 } -result 3
 
+# -------------------------------------------------------------------------
+# info linkedname
+test info-41.0 {info linkedname - valid} -body {
+    proc getname {var} { upvar 1 $var up ; return [info linkedname up] }
+    set i 1
+    getname i
+} -result {i}
+test info-41.1 {info linkedname - valid} -body {
+    proc getname {var} { upvar 1 $var up ; return [info linkedname up] }
+    proc p {i} { return [getname i] }
+    p 2
+} -result {i}
+test info-41.2 {info linkedname - valid} -body {
+    proc getname {var} { upvar 1 $var up ; return [info linkedname up] }
+    array set a {1 one 2 two}
+    getname a(1)
+} -result {a(1)}
+test info-41.3 {info linkedname - no such variable} -body {
+    info linkedname foo
+} -returnCodes error -result {can't access "foo": no such variable}
+test info-41.4 {info linkedname - not a varlink object} -body {
+    set i 5
+    info linkedname i
+} -returnCodes error -result {can't access "i": variable isn't a link}
+
 # cleanup
 catch {namespace delete test_ns_info1 test_ns_info2}
 ::tcltest::cleanupTests