Index: generic/tclCmdIL.c ================================================================== --- generic/tclCmdIL.c +++ generic/tclCmdIL.c @@ -176,10 +176,11 @@ {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"sharedlibextension", InfoSharedlibCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"tclversion", InfoTclVersionCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"upvar", TclInfoUpvarCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"vars", TclInfoVarsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; /* Index: generic/tclInt.h ================================================================== --- generic/tclInt.h +++ generic/tclInt.h @@ -3198,10 +3198,11 @@ MODULE_SCOPE Tcl_ObjCmdProc TclInfoExistsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoCoroutineCmd; MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoUpvarCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( Index: generic/tclVar.c ================================================================== --- generic/tclVar.c +++ generic/tclVar.c @@ -5833,10 +5833,106 @@ "unknown variable \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", name, NULL); } return (Tcl_Var) varPtr; } + +/* + *---------------------------------------------------------------------- + * + * InfoUpvarCmd -- + * + * Called to implement the "info upvar" command that returns the target + * of an upvar command given the alias. The return value is a list. + * If the argument is not an alias, the list is empty. Otherwise the + * list consists of 2 or 3 elements: level name ?subscript? + * The subscript element is only present if name is an array. + * + * info upvar name + * + * If the argument is not a variable, an error is raised. + * + * 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 +TclInfoUpvarCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr; + Tcl_Obj *listPtr, *varObjPtr, *elemObjPtr = NULL; + Interp *iPtr = (Interp *) interp; + CallFrame *framePtr; + const char *errMsg = NULL; + int index, level = 0; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "name"); + return TCL_ERROR; + } + varPtr = TclLookupSimpleVar(interp, objv[1], + TCL_LEAVE_ERR_MSG, 0, &errMsg, &index); + if (varPtr == NULL) { + TclObjVarErrMsg(interp, objv[1], NULL, "stat", errMsg, -1); + return TCL_ERROR; + } + if (TclIsVarLink(varPtr)) { + Tcl_HashTable *tablePtr; + varPtr = varPtr->value.linkPtr; + if (TclIsVarArrayElement(varPtr)) { + ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) + ((VarInHash *) varPtr)->entry.tablePtr; + elemObjPtr = VarHashGetKey(varPtr); + varPtr = avhtPtr->table.arrayPtr; + } + + /* + * Walk up the call frames and compare the local variable hash table + * against the hash table that contains the alias we're looking for + */ + + tablePtr = ((VarInHash *) varPtr)->entry.tablePtr; + for (framePtr = iPtr->varFramePtr; framePtr != NULL; + framePtr = framePtr->callerVarPtr) { + if ((Tcl_HashTable *)framePtr->varTablePtr == tablePtr) { + level = (int)framePtr->level; + break; + } + } + + if (level == 0 && TclGetVarNsPtr(varPtr) != iPtr->globalNsPtr) { + /* + * The reference variable must be a namespace variable. + * In that case thefull name must be reported. + */ + TclNewObj(varObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var)varPtr, varObjPtr); + } else { + varObjPtr = VarHashGetKey(varPtr); + } + + listPtr = Tcl_NewListObj(2, NULL); + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(level)); + Tcl_ListObjAppendElement(interp, listPtr, varObjPtr); + if (elemObjPtr) { + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + Tcl_SetObjResult(interp, listPtr); + } + + return TCL_OK; +} /* *---------------------------------------------------------------------- * * InfoVarsCmd -- (moved over from tclCmdIL.c) Index: tests/info.test ================================================================== --- tests/info.test +++ tests/info.test @@ -676,20 +676,20 @@ test info-21.1 {miscellaneous error conditions} -returnCodes error -body { info } -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, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, upvar, 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, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, upvar, 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, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, upvar, 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, loaded, locals, nameofexecutable, object, patchlevel, procs, script, sharedlibextension, tclversion, upvar, or vars} ## # ### ### ### ######### ######### ######### ## info frame