Handle global/namespace variables better.

doc/info.n

@@ -330,6 +330,23 @@ 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
+.VS TIP471
+Returns the name of the variable that link variable \fIvarname\fR is
+ultimately linked to. This will be a fully qualified name if the variable
+ultimately linked to is in a namespace (including the global namespace). Array
+elements will be indicated by having
+.QW \fB(\fR ,
+the name of the element, and
+.QW \fB)\fR
+appended.
+.RS
+.PP
+Link variables are (usually) local variables created by \fBupvar\fR,
+\fBglobal\fR, \fBnamespace upvar\fR, and \fBvariable\fR.
+.RE
+.VE TIP471
+.TP
 \fBinfo loaded \fR?\fIinterp\fR? ?\fIpackage\fR?
 .
 Returns the filename loaded as part of \fIpackage\fR. If \fIpackage\fR

generic/tclCmdIL.c

@@ -171,6 +171,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, 1},

generic/tclInt.h

@@ -235,6 +235,8 @@ typedef struct NamespacePathEntry NamespacePathEntry;
  * 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.
+ *
+ * Note that arrays further extend this. See ArrayVarHashTable in tclVar.c
  */
 
 typedef struct TclVarHashTable {
@@ -3060,6 +3062,8 @@ 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,

generic/tclVar.c

@@ -131,6 +131,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
@@ -165,17 +166,41 @@ typedef struct ArraySearch {
 } ArraySearch;
 
 /*
- * TIP #508: [array default]
+ * TIP #471: [info linkedname] and TIP #508: [array default]
  *
  * The following structure extends the regular TclVarHashTable used by array
- * variables to store their optional default value.
+ * variables to store a reference to the array and their optional default
+ * value.
  */
 
 typedef struct ArrayVarHashTable {
-    TclVarHashTable table;
-    Tcl_Obj *defaultObj;
+    TclVarHashTable table;	/* The base type, which itself extends
+				 * Tcl_HashTable. */
+    Var *arrayPtr;		/* Reference to the array for which this the
+				 * contents of. */
+    Tcl_Obj *defaultObj;	/* The default value of the array, or NULL if
+				 * there is no default value. */
 } ArrayVarHashTable;
 
+/*
+ * Array access macros.
+ *
+ * ArrayToArrayTable goes from the *array* to its ArrayVarHashTable, whereas
+ * TclGeVarArrayTablePtr goes from an *element* of the array to the array's
+ * ArrayVarHashTable.
+ */
+
+#define ArrayToArrayTable(arrayPtr) \
+    ((ArrayVarHashTable *) (arrayPtr)->value.tablePtr)
+
+#define TclGetVarArrayTablePtr(varPtr) \
+    ((ArrayVarHashTable *) (((VarInHash *) (varPtr))->entry.tablePtr))
+
+#define TclGetVarArrayPtr(varPtr) \
+    (TclIsVarArrayElement(varPtr)		   \
+	? TclGetVarArrayTablePtr(varPtr)->arrayPtr \
+	: NULL)
+
 /*
  * Forward references to functions defined later in this file:
  */
@@ -227,6 +252,8 @@ static void		SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj);
 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;
@@ -1106,6 +1133,81 @@ TclLookupArrayElement(
     return varPtr;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetVarName --
+ *
+ *	Appends the name of a Tcl variable to the objPtr object.
+ *
+ * Results:
+ *	Returns TCL_OK if the variable name was found, TCL_ERROR 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;
+
+    if (TclIsVarInHash(varPtr)) {
+	Var *arrayPtr;
+	int result = TCL_OK;
+
+	if (TclIsVarDeadHash(varPtr)) {
+	    return TCL_ERROR;
+	}
+
+	objNamePtr = VarHashGetKey(varPtr);
+	arrayPtr = TclGetVarArrayPtr(varPtr);
+	if (arrayPtr) {
+	    result = TclGetVarName(interp, arrayPtr, objPtr);
+	    Tcl_AppendToObj(objPtr, "(", 1);
+	    Tcl_AppendObjToObj(objPtr, objNamePtr);
+	    Tcl_AppendToObj(objPtr, ")", 1);
+	} else {
+	    Tcl_Namespace *nsPtr = (Tcl_Namespace*) TclGetVarNsPtr(varPtr);
+
+	    if (nsPtr) {
+		Tcl_AppendToObj(objPtr, nsPtr->fullName, -1);
+		if (nsPtr != Tcl_GetGlobalNamespace(interp)) {
+		    Tcl_AppendToObj(objPtr, "::", 2);
+		}
+	    }
+	    Tcl_AppendObjToObj(objPtr, objNamePtr);
+	}
+	return result;
+    }
+
+    /*
+     * 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 TCL_OK;
+	}
+    }
+
+    return TCL_ERROR;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -1436,11 +1538,10 @@ TclPtrGetVarIdx(
 	 * element of the array.
 	 */
 
-	ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *)
-		((VarInHash *) varPtr)->entry.tablePtr;
+	ArrayVarHashTable *tablePtr = TclGetVarArrayTablePtr(varPtr);
 
-	if (avhtPtr->defaultObj) {
-	    return avhtPtr->defaultObj;
+	if (tablePtr->defaultObj) {
+	    return tablePtr->defaultObj;
 	}
     }
 
@@ -3343,6 +3444,7 @@ ArrayPopulateSearch(
 	    TclGetString(arrayNameObj));
     Tcl_IncrRefCount(searchPtr->name);
 }
+
 /*
  *----------------------------------------------------------------------
  *
@@ -3362,7 +3464,6 @@ ArrayPopulateSearch(
  */
 
 	/* ARGSUSED */
-
 static int
 ArrayStartSearchCmd(
     ClientData clientData,
@@ -4915,7 +5016,6 @@ Tcl_GetVariableFullName(
 {
     Interp *iPtr = (Interp *) interp;
     register Var *varPtr = (Var *) variable;
-    Tcl_Obj *namePtr;
     Namespace *nsPtr;
 
     if (!varPtr || TclIsVarArrayElement(varPtr)) {
@@ -4934,19 +5034,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);
-	}
-    }
+    (void) TclGetVarName(interp, varPtr, objPtr);
 }
 
 /*
@@ -6280,6 +6368,74 @@ TclInfoGlobalsCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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",
+		Tcl_GetString(varName), NULL);
+	return TCL_ERROR;
+    }
+
+    objNamePtr = Tcl_NewObj();
+    if (TclGetVarName(interp, varPtr->value.linkPtr, objNamePtr) != TCL_OK) {
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"unable to find linked name for \"%s\"",
+		Tcl_GetString(varName)));
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARLINK",
+		Tcl_GetString(varName), NULL);
+	TclDecrRefCount(objNamePtr);
+	return TCL_ERROR;
+    }
+
+    Tcl_SetObjResult(interp, objNamePtr);
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -6769,6 +6925,7 @@ TclInitArrayVar(
 
     arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr;
     TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr));
+    tablePtr->arrayPtr = arrayPtr;
 
     /*
      * Default value initialization.
@@ -6785,8 +6942,7 @@ static void
 DeleteArrayVar(
     Var *arrayPtr)
 {
-    ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
-	    arrayPtr->value.tablePtr;
+    ArrayVarHashTable *tablePtr = ArrayToArrayTable(arrayPtr);
 
     /*
      * Default value cleanup.
@@ -6810,8 +6966,7 @@ Tcl_Obj *
 TclGetArrayDefault(
     Var *arrayPtr)
 {
-    ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
-	    arrayPtr->value.tablePtr;
+    ArrayVarHashTable *tablePtr = ArrayToArrayTable(arrayPtr);
 
     return tablePtr->defaultObj;
 }
@@ -6825,8 +6980,7 @@ SetArrayDefault(
     Var *arrayPtr,
     Tcl_Obj *defaultObj)
 {
-    ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)
-	    arrayPtr->value.tablePtr;
+    ArrayVarHashTable *tablePtr = ArrayToArrayTable(arrayPtr);
 
     /*
      * Increment/decrement refcount twice to ensure that the object is shared,

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, cmdtype, 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, cmdtype, 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, cmdtype, 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, cmdtype, 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, cmdtype, 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, cmdtype, 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, cmdtype, 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, cmdtype, commands, complete, coroutine, default, errorstack, exists, frame, functions, globals, hostname, level, library, linkedname, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, or vars}
 
 ##
 # ### ### ### ######### ######### #########
@@ -2583,6 +2583,94 @@ test info-39.2 {Bug 4b61afd660} -setup {
     rename probe {}
 } -result 3
 
+# -------------------------------------------------------------------------
+# info linkedname
+test info-41.1 {info linkedname - valid} -setup {
+    unset -nocomplain i
+} -body {
+    set i 1
+    apply {var {
+	upvar 1 $var up
+	return [info linkedname up]
+    }} i
+} -cleanup {
+    unset -nocomplain i
+} -result ::i
+test info-41.2 {info linkedname - valid} -body {
+    proc getname {var} {
+	upvar 1 $var up
+	return [info linkedname up]
+    }
+    proc p {i} {
+	return [getname i]
+    }
+    p 2
+} -cleanup {
+    catch {rename getname ""}
+    catch {rename p ""}
+} -result {i}
+test info-41.3 {info linkedname - valid} -setup {
+    unset -nocomplain a
+} -body {
+    array set a {1 one 2 two}
+    apply {{var idx} {
+	upvar 1 ${var}($idx) up
+	return [info linkedname up]
+    }} a 1
+} -cleanup {
+    unset -nocomplain a
+} -result {::a(1)}
+test info-41.4 {info linkedname - no such variable} -body {
+    info linkedname foo
+} -returnCodes error -result {can't access "foo": no such variable}
+test info-41.5 {info linkedname - not a varlink object} -setup {
+    unset -nocomplain i
+} -body {
+    set i 5
+    info linkedname i
+} -cleanup {
+    unset -nocomplain i
+} -returnCodes error -result {can't access "i": variable isn't a link}
+test info-41.6 {info linkedname - valid} -body {
+    apply {{} {
+	set ok 123
+	upvar 0 ok gorp
+	return [info linkedname gorp]
+    }}
+} -cleanup {
+    unset -nocomplain a
+} -result {ok}
+test info-41.7 {info linkedname - valid} -setup {
+    unset -nocomplain ok
+} -body {
+    set ok 123
+    apply {{} {
+	variable ok
+	set other 123
+	return [list [info linkedname ok] [catch {info linkedname other} msg] $msg]
+    }}
+} -cleanup {
+    unset -nocomplain ok
+} -result {::ok 1 {can't access "other": variable isn't a link}}
+test info-41.8 {info linkedname - chain of links} -setup {
+    unset -nocomplain ok
+} -body {
+    apply {v {
+	apply {v {
+	    upvar ok foo
+	    apply {v {
+		upvar foo(yes) bar
+		apply {v {
+		    upvar 1 $v gorp
+		    list [info exist gorp] [info linkedname gorp]
+		}} $v
+	    }} $v
+	}} $v
+    }} bar
+} -cleanup {
+    unset -nocomplain ok
+} -result {0 ok(yes)}
+
 # cleanup
 catch {namespace delete test_ns_info1 test_ns_info2}
 ::tcltest::cleanupTests