diff options
Diffstat (limited to 'generic/tclCmdIL.c')
| -rw-r--r-- | generic/tclCmdIL.c | 455 |
1 files changed, 6 insertions, 449 deletions
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index a501105..d3decd7 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.121 2007/07/01 14:49:43 msofer Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.122 2007/07/31 17:03:36 msofer Exp $ */ #include "tclInt.h" @@ -97,8 +97,6 @@ typedef struct SortInfo { * Forward declarations for procedures defined in this file: */ -static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - CONST char *pattern, int includeLinks); static int DictionaryCompare(char *left, char *right); static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -119,8 +117,6 @@ static int InfoFrameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoFunctionsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int InfoGlobalsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); static int InfoHostnameCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLevelCmd(ClientData dummy, Tcl_Interp *interp, @@ -129,8 +125,6 @@ static int InfoLibraryCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoLoadedCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int InfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); static int InfoNameOfExecutableCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); @@ -144,8 +138,6 @@ static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static int InfoVarsCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]); static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); @@ -172,19 +164,19 @@ static const struct { {"exists", InfoExistsCmd}, {"frame", InfoFrameCmd}, {"functions", InfoFunctionsCmd}, - {"globals", InfoGlobalsCmd}, + {"globals", TclInfoGlobalsCmd}, {"hostname", InfoHostnameCmd}, {"level", InfoLevelCmd}, {"library", InfoLibraryCmd}, {"loaded", InfoLoadedCmd}, - {"locals", InfoLocalsCmd}, + {"locals", TclInfoLocalsCmd}, {"nameofexecutable",InfoNameOfExecutableCmd}, {"patchlevel", InfoPatchLevelCmd}, {"procs", InfoProcsCmd}, {"script", InfoScriptCmd}, {"sharedlibextension", InfoSharedlibCmd}, {"tclversion", InfoTclVersionCmd}, - {"vars", InfoVarsCmd}, + {"vars", TclInfoVarsCmd}, {NULL, NULL} }; @@ -1033,8 +1025,8 @@ InfoExistsCmd( varName = TclGetString(objv[1]); varPtr = TclVarTraceExists(interp, varName); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - ((varPtr != NULL) && !TclIsVarUndefined(varPtr)))); + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj(varPtr && varPtr->value.objPtr)); return TCL_OK; } @@ -1359,94 +1351,6 @@ InfoFunctionsCmd( /* *---------------------------------------------------------------------- * - * InfoGlobalsCmd -- - * - * Called to implement the "info globals" command that returns the list - * of global variables matching an optional pattern. Handles the - * following syntax: - * - * info globals ?pattern? - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -InfoGlobalsCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ -{ - char *varName, *pattern; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - Var *varPtr; - Tcl_Obj *listPtr; - - if (objc == 1) { - pattern = NULL; - } else if (objc == 2) { - pattern = TclGetString(objv[1]); - - /* - * Strip leading global-namespace qualifiers. [Bug 1057461] - */ - - if (pattern[0] == ':' && pattern[1] == ':') { - while (*pattern == ':') { - pattern++; - } - } - } else { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; - } - - /* - * Scan through the global :: namespace's variable table and create a list - * of all global variables that match the pattern. - */ - - listPtr = Tcl_NewListObj(0, NULL); - if (pattern != NULL && TclMatchIsTrivial(pattern)) { - entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(pattern, -1)); - } - } - } else { - for (entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (TclIsVarUndefined(varPtr)) { - continue; - } - varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * InfoHostnameCmd -- * * Called to implement the "info hostname" command that returns the host @@ -1650,162 +1554,6 @@ InfoLoadedCmd( /* *---------------------------------------------------------------------- * - * InfoLocalsCmd -- - * - * Called to implement the "info locals" command to return a list of - * local variables that match an optional pattern. Handles the following - * syntax: - * - * info locals ?pattern? - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -InfoLocalsCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - char *pattern; - Tcl_Obj *listPtr; - - if (objc == 1) { - pattern = NULL; - } else if (objc == 2) { - pattern = TclGetString(objv[1]); - } else { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; - } - - if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC )) { - return TCL_OK; - } - - /* - * Return a list containing names of first the compiled locals (i.e. the - * ones stored in the call frame), then the variables in the local hash - * table (if one exists). - */ - - listPtr = Tcl_NewListObj(0, NULL); - AppendLocals(interp, listPtr, pattern, 0); - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * AppendLocals -- - * - * Append the local variables for the current frame to the specified list - * object. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -AppendLocals( - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Obj *listPtr, /* List object to append names to. */ - CONST char *pattern, /* Pattern to match against. */ - int includeLinks) /* 1 if upvars should be included, else 0. */ -{ - Interp *iPtr = (Interp *) interp; - CompiledLocal *localPtr; - Var *varPtr; - int i, localVarCt; - const char *varName; - Tcl_HashTable *localVarTablePtr; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - - localPtr = iPtr->varFramePtr->procPtr->firstLocalPtr; - localVarCt = iPtr->varFramePtr->numCompiledLocals; - varPtr = iPtr->varFramePtr->compiledLocals; - localVarTablePtr = iPtr->varFramePtr->varTablePtr; - - for (i = 0; i < localVarCt; i++) { - /* - * Skip nameless (temporary) variables and undefined variables. - */ - - if (!TclIsVarTemporary(localPtr) && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - varName = varPtr->name; - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - varPtr++; - localPtr = localPtr->nextPtr; - } - - /* - * Do nothing if no local variables. - */ - - if (localVarTablePtr == NULL) { - return; - } - - /* - * Check for the simple and fast case. - */ - - if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { - entryPtr = Tcl_FindHashEntry(localVarTablePtr, pattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(pattern, -1)); - } - } - return; - } - - /* - * Scan over and process all local variables. - */ - - for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); - entryPtr != NULL; - entryPtr = Tcl_NextHashEntry(&search)) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { - varName = Tcl_GetHashKey(localVarTablePtr, entryPtr); - if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } -} - -/* - *---------------------------------------------------------------------- - * * InfoNameOfExecutableCmd -- * * Called to implement the "info nameofexecutable" command that returns @@ -2206,197 +1954,6 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * - * InfoVarsCmd -- - * - * Called to implement the "info vars" command that returns the list of - * variables in the interpreter that match an optional pattern. The - * pattern, if any, consists of an optional sequence of namespace names - * separated by "::" qualifiers, which is followed by a glob-style - * pattern that restricts which variables are returned. Handles the - * following syntax: - * - * info vars ?pattern? - * - * 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. - * - *---------------------------------------------------------------------- - */ - -static int -InfoVarsCmd( - ClientData dummy, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *CONST objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - char *varName, *pattern; - CONST char *simplePattern; - register Tcl_HashEntry *entryPtr; - Tcl_HashSearch search; - Var *varPtr; - Namespace *nsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_Obj *listPtr, *elemObjPtr; - int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ - - /* - * Get the pattern and find the "effective namespace" in which to list - * variables. We only use this effective namespace if there's no active - * Tcl procedure frame. - */ - - if (objc == 1) { - simplePattern = NULL; - nsPtr = currNsPtr; - specificNsInPattern = 0; - } else if (objc == 2) { - /* - * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an error - * was found while parsing the pattern, return it. Otherwise, if the - * namespace wasn't found, just leave nsPtr NULL: we will return an - * empty list since no variables there can be found. - */ - - Namespace *dummy1NsPtr, *dummy2NsPtr; - - pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, (Namespace *) NULL, - /*flags*/ 0, &nsPtr, &dummy1NsPtr, &dummy2NsPtr, - &simplePattern); - - if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ - specificNsInPattern = (strcmp(simplePattern, pattern) != 0); - } - } else { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; - } - - /* - * If the namespace specified in the pattern wasn't found, just return. - */ - - if (nsPtr == NULL) { - return TCL_OK; - } - - listPtr = Tcl_NewListObj(0, NULL); - - if (!(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) - || specificNsInPattern) { - /* - * There is no frame pointer, the frame pointer was pushed only to - * activate a namespace, or we are in a procedure call frame but a - * specific namespace was specified. Create a list containing only the - * variables in the effective namespace's variable table. - */ - - if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { - /* - * If we can just do hash lookups, that simplifies things a lot. - */ - - entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = Tcl_NewStringObj(simplePattern, -1); - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, - simplePattern); - if (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(simplePattern, -1)); - } - } - } - } else { - /* - * Have to scan the tables of variables. - */ - - entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search); - while (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (specificNsInPattern) { - elemObjPtr = Tcl_NewObj(); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = Tcl_NewStringObj(varName, -1); - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } - entryPtr = Tcl_NextHashEntry(&search); - } - - /* - * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern (i.e., the - * pattern only specifies variable names), then add in all global - * :: variables that match the simple pattern. Of course, add in - * only those variables that aren't hidden by a variable in the - * effective namespace. - */ - - if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable,&search); - while (entryPtr != NULL) { - varPtr = (Var *) Tcl_GetHashValue(entryPtr); - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - varName = Tcl_GetHashKey(&globalNsPtr->varTable, - entryPtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (Tcl_FindHashEntry(&nsPtr->varTable, - varName) == NULL) { - Tcl_ListObjAppendElement(interp, listPtr, - Tcl_NewStringObj(varName, -1)); - } - } - } - entryPtr = Tcl_NextHashEntry(&search); - } - } - } - } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePattern, 1); - } - - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the |