diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclCmdIL.c | 205 | ||||
| -rw-r--r-- | generic/tclInt.decls | 6 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 12 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 3 | ||||
| -rw-r--r-- | generic/tclUtil.c | 39 |
6 files changed, 221 insertions, 51 deletions
@@ -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 |