summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-10-14 15:05:59 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-10-14 15:05:59 (GMT)
commit97449587f00016cab8acc385844a1d82f26332c6 (patch)
treef89998d33d66eb6a7f9fe5e3f2d931293830c8a9
parent98a60867761d8d1991cee931a2c8c21423e5dcd1 (diff)
downloadtcl-97449587f00016cab8acc385844a1d82f26332c6.zip
tcl-97449587f00016cab8acc385844a1d82f26332c6.tar.gz
tcl-97449587f00016cab8acc385844a1d82f26332c6.tar.bz2
Speed up [info <thing> <simplePattern>]
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclCmdIL.c205
-rw-r--r--generic/tclInt.decls6
-rw-r--r--generic/tclIntDecls.h12
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclUtil.c39
6 files changed, 221 insertions, 51 deletions
diff --git a/ChangeLog b/ChangeLog
index d8922af..c3b855c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2004-10-14 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclUtil.c (TclMatchIsTrivial): Detect degenerate cases
+ of glob matching that let us avoid scanning through hash tables.
+ * generic/tclCmdIL.c (InfoCommandsCmd, InfoGlobalsCmd, InfoProcsCmd):
+ (InfoVarsCmd): Use this to speed up some [info] subcommands.
+
2004-10-12 Kevin B. Kenny <kennykb@acm.org>
* library/tzdata/America/Campo_Grande:
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 7f58df2..2997509 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -15,7 +15,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.64 2004/10/06 09:37:46 dkf Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.65 2004/10/14 15:06:01 dkf Exp $
*/
#include "tclInt.h"
@@ -746,6 +746,14 @@ InfoCommandsCmd(dummy, interp, objc, objv)
}
/*
+ * Exit as quickly as possible if we couldn't find the namespace.
+ */
+
+ if (nsPtr == NULL) {
+ return TCL_OK;
+ }
+
+ /*
* Scan through the effective namespace's command table and create a
* list with all commands that match the pattern. If a specific
* namespace was requested in the pattern, qualify the command names
@@ -754,7 +762,33 @@ InfoCommandsCmd(dummy, interp, objc, objv)
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- if (nsPtr != NULL) {
+ if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
+ /*
+ * Special case for when the pattern doesn't include any of
+ * glob's special characters. This lets us avoid scans of any
+ * hash tables.
+ */
+ entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
+ if (entryPtr != NULL) {
+ if (specificNsInPattern) {
+ cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, cmd, elemObjPtr);
+ } else {
+ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
+ simplePattern);
+ if (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(cmdName, -1));
+ }
+ }
+ } else {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
@@ -1069,17 +1103,25 @@ InfoGlobalsCmd(dummy, interp, objc, objv)
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- 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)) {
+ if (pattern != NULL && TclMatchIsTrivial(pattern)) {
+ entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable, pattern);
+ if (entryPtr != NULL) {
Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
+ 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);
@@ -1585,6 +1627,10 @@ InfoProcsCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
+ if (nsPtr == NULL) {
+ return TCL_OK;
+ }
+
/*
* Scan through the effective namespace's command table and create a
* list with all procs that match the pattern. If a specific
@@ -1593,7 +1639,33 @@ InfoProcsCmd(dummy, interp, objc, objv)
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
- if (nsPtr != NULL) {
+#ifndef INFO_PROCS_SEARCH_GLOBAL_NS
+ if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) {
+ entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
+ if (entryPtr != NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+
+ if (!TclIsProc(cmdPtr)) {
+ realCmdPtr = (Command *)
+ TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
+ goto simpleProcOK;
+ }
+ } else {
+ simpleProcOK:
+ if (specificNsInPattern) {
+ elemObjPtr = Tcl_NewObj();
+ Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
+ elemObjPtr);
+ } else {
+ elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
+ }
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ }
+ }
+ } else
+#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */
+ {
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
@@ -1601,11 +1673,14 @@ InfoProcsCmd(dummy, interp, objc, objv)
|| Tcl_StringMatch(cmdName, simplePattern)) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
- realCmdPtr = (Command *)
- TclGetOriginalCommand((Tcl_Command) cmdPtr);
-
- if (TclIsProc(cmdPtr)
- || ((realCmdPtr != NULL) && TclIsProc(realCmdPtr))) {
+ if (!TclIsProc(cmdPtr)) {
+ realCmdPtr = (Command *)
+ TclGetOriginalCommand((Tcl_Command) cmdPtr);
+ if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) {
+ goto procOK;
+ }
+ } else {
+ procOK:
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr,
@@ -1613,7 +1688,6 @@ InfoProcsCmd(dummy, interp, objc, objv)
} else {
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
-
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
}
@@ -1893,54 +1967,91 @@ InfoVarsCmd(dummy, interp, objc, objv)
* only the variables in the effective namespace's variable table.
*/
- entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
- while (entryPtr != NULL) {
- varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)
- || (varPtr->flags & VAR_NAMESPACE_VAR)) {
- varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
- if ((simplePattern == NULL)
- || Tcl_StringMatch(varName, simplePattern)) {
+ 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)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
if (specificNsInPattern) {
elemObjPtr = Tcl_NewObj();
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr,
- elemObjPtr);
+ elemObjPtr);
} else {
- elemObjPtr = Tcl_NewStringObj(varName, -1);
+ elemObjPtr = Tcl_NewStringObj(simplePattern, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
}
+ } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ entryPtr = Tcl_FindHashEntry(&globalNsPtr->varTable,
+ simplePattern);
+ varPtr = (Var *) Tcl_GetHashValue(entryPtr);
+ if (!TclIsVarUndefined(varPtr)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(simplePattern, -1));
+ }
}
- 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.
- */
+ } else {
+ /*
+ * Have to scan the tables of variables.
+ */
- if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
if (!TclIsVarUndefined(varPtr)
|| (varPtr->flags & VAR_NAMESPACE_VAR)) {
- varName = Tcl_GetHashKey(&globalNsPtr->varTable, entryPtr);
+ varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
- if (Tcl_FindHashEntry(&nsPtr->varTable,
- varName) == NULL) {
- Tcl_ListObjAppendElement(interp, listPtr,
- Tcl_NewStringObj(varName, -1));
+ 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)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
+ 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);
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index e25d521..36b19a8 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.80 2004/10/01 12:45:18 dkf Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.81 2004/10/14 15:06:02 dkf Exp $
library tcl
@@ -806,6 +806,10 @@ declare 198 generic {
CallFrame **framePtrPtr)
}
+declare 199 generic {
+ int TclMatchIsTrivial(CONST char *pattern)
+}
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index e620e94..6f80d37 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -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: tclIntDecls.h,v 1.70 2004/10/01 12:45:19 dkf Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.71 2004/10/14 15:06:02 dkf Exp $
*/
#ifndef _TCLINTDECLS
@@ -1019,6 +1019,11 @@ EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp,
EXTERN int TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr, CallFrame ** framePtrPtr));
#endif
+#ifndef TclMatchIsTrivial_TCL_DECLARED
+#define TclMatchIsTrivial_TCL_DECLARED
+/* 199 */
+EXTERN int TclMatchIsTrivial _ANSI_ARGS_((CONST char * pattern));
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1238,6 +1243,7 @@ typedef struct TclIntStubs {
void (*tclFinalizeThreadStorageDataKey) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 196 */
int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */
int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */
+ int (*tclMatchIsTrivial) _ANSI_ARGS_((CONST char * pattern)); /* 199 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1921,6 +1927,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclObjGetFrame \
(tclIntStubsPtr->tclObjGetFrame) /* 198 */
#endif
+#ifndef TclMatchIsTrivial
+#define TclMatchIsTrivial \
+ (tclIntStubsPtr->tclMatchIsTrivial) /* 199 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index e4a28d0..de789c6 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.104 2004/10/01 12:45:20 dkf Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.105 2004/10/14 15:06:03 dkf Exp $
*/
#include "tclInt.h"
@@ -283,6 +283,7 @@ TclIntStubs tclIntStubs = {
TclFinalizeThreadStorageDataKey, /* 196 */
TclCompEvalObj, /* 197 */
TclObjGetFrame, /* 198 */
+ TclMatchIsTrivial, /* 199 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 1a4b841..068a20b 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.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: tclUtil.c,v 1.47 2004/10/06 15:59:25 dgp Exp $
+ * RCS: @(#) $Id: tclUtil.c,v 1.48 2004/10/14 15:06:03 dkf Exp $
*/
#include "tclInt.h"
@@ -1416,6 +1416,43 @@ Tcl_StringCaseMatch(string, pattern, nocase)
/*
*----------------------------------------------------------------------
*
+ * TclMatchIsTrivial --
+ *
+ * Test whether a particular glob pattern is a trivial pattern.
+ * (i.e. where matching is the same as equality testing).
+ *
+ * Results:
+ * A boolean indicating whether the pattern is free of all of the
+ * glob special chars.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclMatchIsTrivial(pattern)
+ CONST char *pattern;
+{
+ CONST char *p = pattern;
+
+ while (1) {
+ switch (*p++) {
+ case '\0':
+ return 1;
+ case '*':
+ case '?':
+ case '[':
+ case '\\':
+ return 0;
+ }
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* Tcl_DStringInit --
*
* Initializes a dynamic string, discarding any previous contents