summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclClock.c6
-rw-r--r--generic/tclCmdIL.c137
-rw-r--r--generic/tclNamesp.c3
-rw-r--r--generic/tclThreadTest.c4
4 files changed, 116 insertions, 34 deletions
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 13bf229..ccf6638 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclClock.c,v 1.6 2000/01/08 02:31:22 ericm Exp $
+ * RCS: @(#) $Id: tclClock.c,v 1.7 2000/01/12 11:12:52 hobbs Exp $
*/
#include "tcl.h"
@@ -263,6 +263,7 @@ FormatClock(interp, clockVal, useGMT, format)
char *p;
Tcl_Obj *resultPtr;
int result;
+ time_t tclockVal;
#ifndef HAVE_TM_ZONE
int savedTimeZone = 0; /* lint. */
char *savedTZEnv = NULL; /* lint. */
@@ -306,7 +307,8 @@ FormatClock(interp, clockVal, useGMT, format)
}
#endif
- timeDataPtr = TclpGetDate((TclpTime_t) &clockVal, useGMT);
+ tclockVal = clockVal;
+ timeDataPtr = TclpGetDate((TclpTime_t) &tclockVal, useGMT);
/*
* Make a guess at the upper limit on the substituted string size
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 6e7e908..bacf7e6 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -14,7 +14,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.19 1999/12/21 23:58:03 hobbs Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.20 2000/01/12 11:12:52 hobbs Exp $
*/
#include "tclInt.h"
@@ -1420,9 +1420,12 @@ InfoPatchLevelCmd(dummy, interp, objc, objv)
*
* InfoProcsCmd --
*
- * Called to implement the "info procs" command that returns the
- * procedures in the current namespace that match an optional pattern.
- * Handles the following syntax:
+ * Called to implement the "info procs" command that returns the
+ * list of procedures 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 commands are returned.
+ * Handles the following syntax:
*
* info procs ?pattern?
*
@@ -1443,50 +1446,126 @@ InfoProcsCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *cmdName, *pattern;
- Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ char *cmdName, *pattern, *simplePattern;
+ Namespace *nsPtr;
+#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
+ Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
+#endif
+ Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ Tcl_Obj *listPtr, *elemObjPtr;
+ int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Command *cmdPtr, *realCmdPtr;
- Tcl_Obj *listPtr;
+
+ /*
+ * Get the pattern and find the "effective namespace" in which to
+ * list procs.
+ */
if (objc == 2) {
- pattern = NULL;
+ simplePattern = NULL;
+ nsPtr = currNsPtr;
+ specificNsInPattern = 0;
} else if (objc == 3) {
- pattern = Tcl_GetString(objv[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 commands there can be found.
+ */
+
+ Namespace *dummy1NsPtr, *dummy2NsPtr;
+
+ pattern = Tcl_GetString(objv[2]);
+ 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, 2, objv, "?pattern?");
return TCL_ERROR;
}
/*
- * Scan through the current namespace's command table and return a list
- * of all procs that match the pattern.
+ * Scan through the effective namespace's command table and create a
+ * list with all procs that match the pattern. If a specific
+ * namespace was requested in the pattern, qualify the command names
+ * with the namespace name.
*/
-
+
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- for (entryPtr = Tcl_FirstHashEntry(&currNsPtr->cmdTable, &search);
- entryPtr != NULL;
- entryPtr = Tcl_NextHashEntry(&search)) {
- cmdName = Tcl_GetHashKey(&currNsPtr->cmdTable, entryPtr);
- cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ if (nsPtr != NULL) {
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ }
+
+ realCmdPtr = (Command *)
+ TclGetOriginalCommand((Tcl_Command) cmdPtr);
+
+ if (TclIsProc(cmdPtr)
+ || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
/*
- * If the command isn't itself a proc, it still might be an
- * imported command that points to a "real" proc in a different
- * namespace.
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern, then add in
+ * all global :: procs that match the simple pattern. Of course,
+ * we add in only those procs that aren't hidden by a proc in
+ * the effective namespace.
*/
- realCmdPtr = (Command *) TclGetOriginalCommand(
- (Tcl_Command) cmdPtr);
- if (TclIsProc(cmdPtr)
- || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
- if ((pattern == NULL) || Tcl_StringMatch(cmdName, pattern)) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(cmdName, -1));
- }
- }
+#ifdef INFO_PROCS_SEARCH_GLOBAL_NS
+ /*
+ * If "info procs" worked like "info commands", returning the
+ * commands also seen in the global namespace, then you would
+ * include this code. As this could break backwards compatibilty
+ * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the
+ * behavior slightly different.
+ */
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ if (Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName) == NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ realCmdPtr = (Command *) TclGetOriginalCommand(
+ (Tcl_Command) cmdPtr);
+
+ if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL)
+ && TclIsProc(realCmdPtr))) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(cmdName, -1));
+ }
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
+#endif
}
+
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 4c4b4e5..ea7d0cd 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.13 1999/12/12 02:26:42 hobbs Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.14 2000/01/12 11:12:53 hobbs Exp $
*/
#include "tclInt.h"
@@ -1262,6 +1262,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
(ClientData) dataPtr, DeleteImportedCmd);
dataPtr->realCmdPtr = cmdPtr;
dataPtr->selfPtr = (Command *) importedCmd;
+ dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
/*
* Create an ImportRef structure describing this new import
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 60ea7a9..9aa43d5 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclThreadTest.c,v 1.5 1999/12/21 23:58:04 hobbs Exp $
+ * RCS: @(#) $Id: tclThreadTest.c,v 1.6 2000/01/12 11:12:53 hobbs Exp $
*/
#include "tclInt.h"
@@ -493,7 +493,7 @@ ThreadErrorProc(interp)
Tcl_Channel errChannel;
char *errorInfo, *script;
char *argv[3];
- char buf[10];
+ char buf[TCL_DOUBLE_SPACE+1];
sprintf(buf, "%ld", (long) Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);