diff options
| -rw-r--r-- | doc/info.n | 13 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 2 | ||||
| -rw-r--r-- | generic/tclInt.h | 2 | ||||
| -rw-r--r-- | generic/tclVar.c | 251 | ||||
| -rw-r--r-- | tests/var.test | 66 |
5 files changed, 329 insertions, 5 deletions
@@ -85,6 +85,19 @@ Returns 1 if \fIcommand\fR is a complete command, and \fB0\fR otherwise. Typically used in line-oriented input environments to allow users to type in commands that span multiple lines. .TP +\fBinfo constant \fIvarName\fR +.VS "TIP 677" +Returns 1 if \fIvarName\fR is a constant variable (see \fBconst\fR) and 0 +otherwise. +.VE "TIP 677" +.TP +\fBinfo consts\fR ?\fIpattern\fR? +.VS "TIP 677" +Returns the list of constant variables (see \fBconst\fR) in the current scope, +or the list of constant variables matching \fIpattern\fR (if that is provided) +in a manner similar to \fBinfo vars\fR. +.VE "TIP 677" +.TP \fBinfo coroutine\fR . Returns the name of the current \fBcoroutine\fR, or the empty diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index fb31d44..18842a1 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -160,6 +160,8 @@ static const EnsembleImplMap defaultInfoMap[] = { {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"consts", TclInfoConstsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, diff --git a/generic/tclInt.h b/generic/tclInt.h index cee419a..e9d3006 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3376,6 +3376,8 @@ MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstsCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstantCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); diff --git a/generic/tclVar.c b/generic/tclVar.c index 854f9e6..de7e374 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -180,7 +180,8 @@ typedef struct ArrayVarHashTable { */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *patternPtr, int includeLinks); + Tcl_Obj *patternPtr, int includeLinks, + int justConstants); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); @@ -6145,7 +6146,7 @@ TclInfoVarsCmd( } } } else if (iPtr->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePatternPtr, 1); + AppendLocals(interp, listPtr, simplePatternPtr, 1, 0); } if (simplePatternPtr) { @@ -6299,7 +6300,201 @@ TclInfoLocalsCmd( */ listPtr = Tcl_NewListObj(0, NULL); - AppendLocals(interp, listPtr, patternPtr, 0); + AppendLocals(interp, listPtr, patternPtr, 0, 0); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInfoConstsCmd -- + * + * Called to implement the "info consts" command that returns the list of + * constants 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 consts ?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. + * + *---------------------------------------------------------------------- + */ + +int +TclInfoConstsCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Interp *iPtr = (Interp *) interp; + const char *varName, *pattern, *simplePattern; + Tcl_HashSearch search; + Var *varPtr; + Namespace *nsPtr; + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; + int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ + Tcl_Obj *simplePatternPtr = NULL; + + /* + * 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, NULL, /*flags*/ 0, + &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); + + if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ + specificNsInPattern = (strcmp(simplePattern, pattern) != 0); + if (simplePattern == pattern) { + simplePatternPtr = objv[1]; + } else { + simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); + } + Tcl_IncrRefCount(simplePatternPtr); + } + } 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 (!HasLocalVars(iPtr->varFramePtr) || 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 && TclMatchIsTrivial(simplePattern)) { + /* + * If we can just do hash lookups, that simplifies things a lot. + */ + + varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = VarHashGetKey(varPtr); + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + varPtr = VarHashFindVar(&globalNsPtr->varTable, + simplePatternPtr); + if (varPtr && TclIsVarConstant(varPtr)) { + if (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr)) { + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); + } + } + } + } else { + /* + * Have to scan the tables of variables. + */ + + varPtr = VarHashFirstVar(&nsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (specificNsInPattern) { + TclNewObj(elemObjPtr); + Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, + elemObjPtr); + } else { + elemObjPtr = varNamePtr; + } + Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); + } + } + varPtr = VarHashNextVar(&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) { + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); + while (varPtr) { + if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) + || TclIsVarNamespaceVar(varPtr))) { + varNamePtr = VarHashGetKey(varPtr); + varName = TclGetString(varNamePtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(varName, simplePattern)) { + if (VarHashFindVar(&nsPtr->varTable, + varNamePtr) == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + varNamePtr); + } + } + } + varPtr = VarHashNextVar(&search); + } + } + } + } else if (iPtr->varFramePtr->procPtr != NULL) { + AppendLocals(interp, listPtr, simplePatternPtr, 1, 1); + } + + if (simplePatternPtr) { + Tcl_DecrRefCount(simplePatternPtr); + } Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -6326,7 +6521,8 @@ AppendLocals( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *listPtr, /* List object to append names to. */ Tcl_Obj *patternPtr, /* Pattern to match against. */ - int includeLinks) /* 1 if upvars should be included, else 0. */ + int includeLinks, /* 1 if upvars should be included, else 0. */ + int justConstants) /* 1 if just constants should be included. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; @@ -6355,7 +6551,8 @@ AppendLocals( */ if (*varNamePtr && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { + && (!justConstants || TclIsVarConstant(varPtr)) + && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); @@ -6384,6 +6581,7 @@ AppendLocals( varPtr = VarHashFindVar(localVarTablePtr, patternPtr); if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) + && (!justConstants || TclIsVarConstant(varPtr)) && (includeLinks || !TclIsVarLink(varPtr))) { Tcl_ListObjAppendElement(interp, listPtr, VarHashGetKey(varPtr)); @@ -6404,6 +6602,7 @@ AppendLocals( varPtr != NULL; varPtr = VarHashNextVar(&search)) { if (!TclIsVarUndefined(varPtr) + && (!justConstants || TclIsVarConstant(varPtr)) && (includeLinks || !TclIsVarLink(varPtr))) { objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); @@ -6421,6 +6620,7 @@ AppendLocals( return; } + /* TODO: Handle how constants interact with objects. */ if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { Method *mPtr = (Method *) Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData); @@ -6472,6 +6672,47 @@ AppendLocals( } /* + *---------------------------------------------------------------------- + * + * TclInfoConstantCmd -- + * + * Called to implement the "info constant" command that wests whether a + * specific variable is a constant. Handles the following syntax: + * + * info constant 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 +TclInfoConstantCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Var *varPtr, *arrayPtr; + int result; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "varName"); + return TCL_ERROR; + } + varPtr = TclObjLookupVar(interp, objv[1], NULL, 0, "lookup", 0, 0, + &arrayPtr); + result = (varPtr && TclIsVarConstant(varPtr)); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +/* * Hash table implementation - first, just copy and adapt the obj key stuff */ diff --git a/tests/var.test b/tests/var.test index 26a2e11..0aca974 100644 --- a/tests/var.test +++ b/tests/var.test @@ -1767,6 +1767,72 @@ test var-28.1 {const: globally} -setup { } -cleanup { interp delete $int } -result gorp + +test var-29.1 {info constant and info consts} { + apply {{} { + lappend consts [lsort [info consts]] [info constant X] + const X 1 + lappend consts [lsort [info consts]] [info constant X] + const Y 2 + lappend consts [lsort [info consts]] + const X 3 + lappend consts [lsort [info consts]] + }} +} {{} 0 X 1 {X Y} {X Y}} +test var-29.2 {const and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + const X 1 + lappend consts [lsort [info consts X]] + const Y 2 + lappend consts [lsort [info consts X]] + const X 3 + lappend consts [lsort [info consts X]] + }} +} {{} X X X} +test var-29.3 {const and info consts} { + apply {{} { + lappend consts [lsort [info consts ?]] + const X 1 + lappend consts [lsort [info consts ?]] + const Y 2 + lappend consts [lsort [info consts ?]] + const XX 3 + lappend consts [lsort [info consts ?]] + }} +} {{} X {X Y} {X Y}} +test var-29.4 {const and info consts} { + apply {{} { + lappend consts [lsort [info consts X]] + set X 1 + lappend consts [lsort [info consts X]] + set Y 2 + lappend consts [lsort [info consts X]] + set X 3 + lappend consts [lsort [info consts X]] + }} +} {{} {} {} {}} +test var-29.5 {const: in a namespace} -setup { + namespace eval var29 {} +} -body { + namespace eval var29 { + const X gorp + info consts + } +} -cleanup { + namespace delete var29 +} -result X +test var-29.6 {const: in a namespace} -setup { + namespace eval var29 {} +} -body { + namespace eval var29 { + const X gorp + variable Y foo + } + info consts var29::* +} -cleanup { + namespace delete var29 +} -result ::var29::X catch {namespace delete ns} catch {unset arr} |