Added introspection

5 files changed, 329 insertions, 5 deletions

diff --git a/doc/info.n b/doc/info.n
index b84b2c7..24ed3b8 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -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}