diff options
author | dgp <dgp@users.sourceforge.net> | 2005-05-05 18:37:43 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2005-05-05 18:37:43 (GMT) |
commit | 06ccaebaafb55508004011a0cb9ec73a6872c23b (patch) | |
tree | 528333d487c2d5ed865f278d50536ea98959741c | |
parent | 9c427bf1e80bcbb05860cb838266240040b91f07 (diff) | |
download | tcl-06ccaebaafb55508004011a0cb9ec73a6872c23b.zip tcl-06ccaebaafb55508004011a0cb9ec73a6872c23b.tar.gz tcl-06ccaebaafb55508004011a0cb9ec73a6872c23b.tar.bz2 |
* generic/tclInt.decls: Converted TclMatchIsTrivial to a macro.
* generic/tclInt.h:
* generic/tclUtil.c:
* generic/tclIntDecls.h: `make genstubs`
* generic/tclStubInit.c:
* generic/tclBasic.c: Added callers of TclMatchIsTrivial where
* generic/tclCmdIL.c: a search can be done more efficiently
* generic/tclCompCmds.c:when it is recognized that a pattern match
* generic/tclDictObj.c: is really an exact match. [Patch 1076088]
* generic/tclIO.c:
* generic/tclNamesp.c:
* generic/tclVar.c:
-rw-r--r-- | ChangeLog | 13 | ||||
-rw-r--r-- | generic/tclBasic.c | 11 | ||||
-rw-r--r-- | generic/tclCmdIL.c | 9 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 15 | ||||
-rw-r--r-- | generic/tclDictObj.c | 26 | ||||
-rw-r--r-- | generic/tclIO.c | 15 | ||||
-rw-r--r-- | generic/tclInt.decls | 8 | ||||
-rw-r--r-- | generic/tclInt.h | 15 | ||||
-rw-r--r-- | generic/tclIntDecls.h | 15 | ||||
-rw-r--r-- | generic/tclNamesp.c | 217 | ||||
-rw-r--r-- | generic/tclStubInit.c | 4 | ||||
-rw-r--r-- | generic/tclUtil.c | 39 | ||||
-rw-r--r-- | generic/tclVar.c | 43 |
13 files changed, 266 insertions, 164 deletions
@@ -5,6 +5,19 @@ 2005-05-05 Don Porter <dgp@users.sourceforge.net> + * generic/tclInt.decls: Converted TclMatchIsTrivial to a macro. + * generic/tclInt.h: + * generic/tclUtil.c: + * generic/tclIntDecls.h: `make genstubs` + * generic/tclStubInit.c: + * generic/tclBasic.c: Added callers of TclMatchIsTrivial where + * generic/tclCmdIL.c: a search can be done more efficiently + * generic/tclCompCmds.c:when it is recognized that a pattern match + * generic/tclDictObj.c: is really an exact match. [Patch 1076088] + * generic/tclIO.c: + * generic/tclNamesp.c: + * generic/tclVar.c: + * generic/tclCompCmds.c: Factored common efficiency trick into a macro named CompileWord. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 376fe25..9783367 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.149 2005/05/03 18:07:45 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.150 2005/05/05 18:37:55 dgp Exp $ */ #include "tclInt.h" @@ -2822,6 +2822,14 @@ Tcl_ListMathFuncs(interp, pattern) Tcl_HashSearch hSearch; CONST char *name; + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + if ((Tcl_FindHashEntry(&iPtr->mathFuncTable, pattern) != NULL) + && (Tcl_ListObjAppendElement(interp, resultList, + Tcl_NewStringObj(pattern,-1)) != TCL_OK)) { + goto error; + } + return resultList; + } for (hPtr = Tcl_FirstHashEntry(&iPtr->mathFuncTable, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { name = Tcl_GetHashKey(&iPtr->mathFuncTable, hPtr); @@ -2829,6 +2837,7 @@ Tcl_ListMathFuncs(interp, pattern) /* I don't expect this to fail, but... */ Tcl_ListObjAppendElement(interp, resultList, Tcl_NewStringObj(name,-1)) != TCL_OK) { +error: Tcl_DecrRefCount(resultList); return NULL; } diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 1813fe0..3b61959 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.72 2005/04/02 02:08:31 msofer Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.73 2005/05/05 18:37:56 dgp Exp $ */ #include "tclInt.h" @@ -1455,6 +1455,13 @@ AppendLocals(interp, listPtr, pattern, includeLinks) } if (localVarTablePtr != NULL) { + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + if (Tcl_FindHashEntry(localVarTablePtr, pattern)) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern,-1)); + } + return; + } for (entryPtr = Tcl_FirstHashEntry(localVarTablePtr, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 97e1ff4..bd0c4b7 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.66 2005/05/05 17:21:03 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.67 2005/05/05 18:37:57 dgp Exp $ */ #include "tclInt.h" @@ -2612,18 +2612,13 @@ TclCompileStringCmd(interp, parsePtr, envPtr) length = varTokenPtr[1].size; if (!nocase && (i == 0)) { /* - * On the first (pattern) arg, check to see if any - * glob special characters are in the word '*[]?\\'. - * If not, this is the same as 'string equal'. We - * can use strpbrk here because the glob chars are all - * in the ascii-7 range. If -nocase was specified, - * we can't do this because INST_STR_EQ has no support - * for nocase. + * Trivial matches can be done by 'string equal'. + * If -nocase was specified, we can't do this + * because INST_STR_EQ has no support for nocase. */ Tcl_Obj *copy = Tcl_NewStringObj(str, length); Tcl_IncrRefCount(copy); - exactMatch = (strpbrk(Tcl_GetString(copy), - "*[]?\\") == NULL); + exactMatch = TclMatchIsTrivial(Tcl_GetString(copy)); Tcl_DecrRefCount(copy); } TclEmitPush( diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 2f1b1cd..1dc87d4 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDictObj.c,v 1.29 2005/04/22 15:46:54 dgp Exp $ + * RCS: @(#) $Id: tclDictObj.c,v 1.30 2005/05/05 18:37:58 dgp Exp $ */ #include "tclInt.h" @@ -1671,6 +1671,14 @@ DictKeysCmd(interp, objc, objv) pattern = TclGetString(objv[3]); } listPtr = Tcl_NewListObj(0, NULL); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + Tcl_Obj *valuePtr = NULL; + Tcl_DictObjGet(interp, objv[2], objv[3], &valuePtr); + if (valuePtr != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, objv[3]); + } + goto searchDone; + } for (; !done ; Tcl_DictObjNext(&search, &keyPtr, NULL, &done)) { if (pattern==NULL || Tcl_StringMatch(TclGetString(keyPtr), pattern)) { /* @@ -1679,6 +1687,7 @@ DictKeysCmd(interp, objc, objv) Tcl_ListObjAppendElement(interp, listPtr, keyPtr); } } +searchDone: Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -2531,11 +2540,18 @@ DictFilterCmd(interp, objc, objv) } pattern = TclGetString(objv[4]); resultObj = Tcl_NewDictObj(); - while (!done) { - if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { - Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + if (TclMatchIsTrivial(pattern)) { + Tcl_DictObjGet(interp, objv[2], objv[4], &valueObj); + if (valueObj != NULL) { + Tcl_DictObjPut(interp, resultObj, objv[4], valueObj); + } + } else { + while (!done) { + if (Tcl_StringMatch(TclGetString(keyObj), pattern)) { + Tcl_DictObjPut(interp, resultObj, keyObj, valueObj); + } + Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } - Tcl_DictObjNext(&search, &keyObj, &valueObj, &done); } Tcl_SetObjResult(interp, resultObj); return TCL_OK; diff --git a/generic/tclIO.c b/generic/tclIO.c index 02b4fe8..e94264a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.84 2005/04/14 02:41:15 davygrvy Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.85 2005/05/05 18:37:58 dgp Exp $ */ #include "tclInt.h" @@ -8766,7 +8766,16 @@ Tcl_GetChannelNamesEx(interp, pattern) hTblPtr = GetChannelTable(interp); TclNewObj(resultPtr); - + if ((pattern != NULL) && TclMatchIsTrivial(pattern) + && !((pattern[0] == 's') && (pattern[1] == 't') + && (pattern[2] == 'd'))) { + if ((Tcl_FindHashEntry(hTblPtr, pattern) != NULL) + && (Tcl_ListObjAppendElement(interp, resultPtr, + Tcl_NewStringObj(pattern, -1)) != TCL_OK)) { + goto error; + } + goto done; + } for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); hPtr != (Tcl_HashEntry *) NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { @@ -8790,10 +8799,12 @@ Tcl_GetChannelNamesEx(interp, pattern) if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, -1)) != TCL_OK)) { +error: TclDecrRefCount(resultPtr); return TCL_ERROR; } } +done: Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index be0618f..a997c25 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.86 2005/04/02 02:08:36 msofer Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.87 2005/05/05 18:38:00 dgp Exp $ library tcl @@ -807,9 +807,9 @@ declare 198 generic { CallFrame **framePtrPtr) } -declare 199 generic { - int TclMatchIsTrivial(CONST char *pattern) -} +#declare 199 generic { +# int TclMatchIsTrivial(CONST char *pattern) +#} # 200-208 exported for use by the test suite [Bug 1054748] declare 200 generic { diff --git a/generic/tclInt.h b/generic/tclInt.h index b6f62dc..6af07ff 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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.h,v 1.227 2005/05/05 15:32:20 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.228 2005/05/05 18:38:01 dgp Exp $ */ #ifndef _TCLINT @@ -2718,6 +2718,19 @@ MODULE_SCOPE void TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); /* *---------------------------------------------------------------- + * Macro used by the Tcl core to check whether a pattern has + * any characters special to [string match]. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclMatchIsTrivial _ANSI_ARGS_(( + * CONST char *pattern)); + *---------------------------------------------------------------- + */ + +#define TclMatchIsTrivial(pattern) strpbrk((pattern), "*[]]?\\") == NULL + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to set a Tcl_Obj's numeric representation * avoiding the corresponding function calls in time critical parts of the * core. They should only be called on unshared objects. The ANSI C diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 5d38426..6972a28 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.77 2005/04/02 02:08:56 msofer Exp $ + * RCS: @(#) $Id: tclIntDecls.h,v 1.78 2005/05/05 18:38:02 dgp Exp $ */ #ifndef _TCLINTDECLS @@ -1015,11 +1015,7 @@ 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 +/* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory_TCL_DECLARED #define TclpObjRemoveDirectory_TCL_DECLARED /* 200 */ @@ -1351,7 +1347,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 */ + void *reserved199; int (*tclpObjRemoveDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr, int recursive, Tcl_Obj ** errorPtr)); /* 200 */ int (*tclpObjCopyDirectory) _ANSI_ARGS_((Tcl_Obj * srcPathPtr, Tcl_Obj * destPathPtr, Tcl_Obj ** errorPtr)); /* 201 */ int (*tclpObjCreateDirectory) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 202 */ @@ -2048,10 +2044,7 @@ extern TclIntStubs *tclIntStubsPtr; #define TclObjGetFrame \ (tclIntStubsPtr->tclObjGetFrame) /* 198 */ #endif -#ifndef TclMatchIsTrivial -#define TclMatchIsTrivial \ - (tclIntStubsPtr->tclMatchIsTrivial) /* 199 */ -#endif +/* Slot 199 is reserved */ #ifndef TclpObjRemoveDirectory #define TclpObjRemoveDirectory \ (tclIntStubsPtr->tclpObjRemoveDirectory) /* 200 */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 7365b0a..5cd013e 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,7 +21,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.72 2005/03/09 10:20:37 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.73 2005/05/05 18:38:04 dgp Exp $ */ #include "tclInt.h" @@ -180,6 +180,10 @@ typedef struct EnsembleCmdRep { */ static void DeleteImportedCmd _ANSI_ARGS_((ClientData clientData)); +static int DoImport _ANSI_ARGS_((Tcl_Interp *interp, + Namespace *nsPtr, Tcl_HashEntry *hPtr, + CONST char *cmdName, CONST char *pattern, + Namespace *importNsPtr, int allowOverwrite)); static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); static char * ErrorCodeRead _ANSI_ARGS_(( ClientData clientData, @@ -1490,107 +1494,129 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) * commands redirect their invocations to the "real" command. */ + if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { + hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); + if (hPtr == NULL) { + return TCL_OK; + } + return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, + importNsPtr, allowOverwrite); + } for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); - if (Tcl_StringMatch(cmdName, simplePattern)) { - /* - * The command cmdName in the source namespace matches the - * pattern. Check whether it was exported. If it wasn't, - * we ignore it. - */ - Tcl_HashEntry *found; - int wasExported = 0, i; + if (Tcl_StringMatch(cmdName, simplePattern) + && (TCL_ERROR == DoImport( interp, nsPtr, hPtr, cmdName, + pattern, importNsPtr, allowOverwrite))) { + return TCL_ERROR; + } + } + return TCL_OK; +} - for (i = 0; i < importNsPtr->numExportPatterns; i++) { - if (Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i])) { - wasExported = 1; - break; - } - } - if (!wasExported) { - continue; - } +static int +DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) + Tcl_Interp *interp; + Namespace *nsPtr; + Tcl_HashEntry *hPtr; + CONST char *cmdName; + CONST char *pattern; + Namespace *importNsPtr; + int allowOverwrite; +{ + int i = 0, exported = 0; + Tcl_HashEntry *found; - /* - * Unless there is a name clash, create an imported command - * in the current namespace that refers to cmdPtr. - */ + /* + * The command cmdName in the source namespace matches the + * pattern. Check whether it was exported. If it wasn't, + * we ignore it. + */ - found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); - if ((found == NULL) || allowOverwrite) { - /* - * Create the imported command and its client data. - * To create the new command in the current namespace, - * generate a fully qualified name for it. - */ + while (!exported && (i < importNsPtr->numExportPatterns)) { + exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); + } + if (!exported) { + return TCL_OK; + } - Tcl_DString ds; - Tcl_Command importedCmd; - ImportedCmdData *dataPtr; - Command *cmdPtr; - ImportRef *refPtr; + /* + * Unless there is a name clash, create an imported command + * in the current namespace that refers to cmdPtr. + */ - Tcl_DStringInit(&ds); - Tcl_DStringAppend(&ds, nsPtr->fullName, -1); - if (nsPtr != ((Interp *) interp)->globalNsPtr) { - Tcl_DStringAppend(&ds, "::", 2); - } - Tcl_DStringAppend(&ds, cmdName, -1); + found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); + if ((found == NULL) || allowOverwrite) { + /* + * Create the imported command and its client data. + * To create the new command in the current namespace, + * generate a fully qualified name for it. + */ - /* - * Check whether creating the new imported command in the - * current namespace would create a cycle of imported - * command references. - */ + Tcl_DString ds; + Tcl_Command importedCmd; + ImportedCmdData *dataPtr; + Command *cmdPtr; + ImportRef *refPtr; - cmdPtr = (Command *) Tcl_GetHashValue(hPtr); - if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { - Command *overwrite = (Command *) Tcl_GetHashValue(found); - Command *link = cmdPtr; - - while (link->deleteProc == DeleteImportedCmd) { - ImportedCmdData *dataPtr; - - dataPtr = (ImportedCmdData *) link->objClientData; - link = dataPtr->realCmdPtr; - if (overwrite == link) { - Tcl_AppendResult(interp, "import pattern \"", - pattern, - "\" would create a loop containing ", - "command \"", Tcl_DStringValue(&ds), - "\"", (char *) NULL); - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - } - } + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, nsPtr->fullName, -1); + if (nsPtr != ((Interp *) interp)->globalNsPtr) { + Tcl_DStringAppend(&ds, "::", 2); + } + Tcl_DStringAppend(&ds, cmdName, -1); - dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); - importedCmd = Tcl_CreateObjCommand(interp, - Tcl_DStringValue(&ds), InvokeImportedCmd, - (ClientData) dataPtr, DeleteImportedCmd); - dataPtr->realCmdPtr = cmdPtr; - dataPtr->selfPtr = (Command *) importedCmd; - dataPtr->selfPtr->compileProc = cmdPtr->compileProc; - Tcl_DStringFree(&ds); + /* + * Check whether creating the new imported command in the + * current namespace would create a cycle of imported + * command references. + */ - /* - * Create an ImportRef structure describing this new import - * command and add it to the import ref list in the "real" - * command. - */ + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { + Command *overwrite = (Command *) Tcl_GetHashValue(found); + Command *link = cmdPtr; - refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); - refPtr->importedCmdPtr = (Command *) importedCmd; - refPtr->nextPtr = cmdPtr->importRefPtr; - cmdPtr->importRefPtr = refPtr; - } else { - Tcl_AppendResult(interp, "can't import command \"", cmdName, - "\": already exists", (char *) NULL); - return TCL_ERROR; + while (link->deleteProc == DeleteImportedCmd) { + ImportedCmdData *dataPtr; + + dataPtr = (ImportedCmdData *) link->objClientData; + link = dataPtr->realCmdPtr; + if (overwrite == link) { + Tcl_AppendResult(interp, "import pattern \"", + pattern, + "\" would create a loop containing ", + "command \"", Tcl_DStringValue(&ds), + "\"", (char *) NULL); + Tcl_DStringFree(&ds); + return TCL_ERROR; + } } } + + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); + importedCmd = Tcl_CreateObjCommand(interp, + Tcl_DStringValue(&ds), InvokeImportedCmd, + (ClientData) dataPtr, DeleteImportedCmd); + dataPtr->realCmdPtr = cmdPtr; + dataPtr->selfPtr = (Command *) importedCmd; + dataPtr->selfPtr->compileProc = cmdPtr->compileProc; + Tcl_DStringFree(&ds); + + /* + * Create an ImportRef structure describing this new import + * command and add it to the import ref list in the "real" + * command. + */ + + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); + refPtr->importedCmdPtr = (Command *) importedCmd; + refPtr->nextPtr = cmdPtr->importRefPtr; + cmdPtr->importRefPtr = refPtr; + } else { + Tcl_AppendResult(interp, "can't import command \"", cmdName, + "\": already exists", (char *) NULL); + return TCL_ERROR; } return TCL_OK; } @@ -1670,6 +1696,15 @@ Tcl_ForgetImport(interp, namespacePtr, pattern) * Delete any imported commands that match it. */ + if (TclMatchIsTrivial(simplePattern)) { + Command *cmdPtr; + hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); + (hPtr != NULL) + && (cmdPtr = (Command *) Tcl_GetHashValue(hPtr)) + && (cmdPtr->deleteProc == DeleteImportedCmd) + && Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); + return TCL_OK; + } for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { @@ -2959,6 +2994,13 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + if (Tcl_FindHashEntry(&nsPtr->childTable, pattern) != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(pattern, -1)); + } + goto searchDone; + } entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); while (entryPtr != NULL) { childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); @@ -2970,6 +3012,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) entryPtr = Tcl_NextHashEntry(&search); } +searchDone: Tcl_SetObjResult(interp, listPtr); Tcl_DStringFree(&buffer); return TCL_OK; diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 6dfe793..020f1ab 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.114 2005/04/02 02:08:59 msofer Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.115 2005/05/05 18:38:04 dgp Exp $ */ #include "tclInt.h" @@ -283,7 +283,7 @@ TclIntStubs tclIntStubs = { TclFinalizeThreadStorageDataKey, /* 196 */ TclCompEvalObj, /* 197 */ TclObjGetFrame, /* 198 */ - TclMatchIsTrivial, /* 199 */ + NULL, /* 199 */ TclpObjRemoveDirectory, /* 200 */ TclpObjCopyDirectory, /* 201 */ TclpObjCreateDirectory, /* 202 */ diff --git a/generic/tclUtil.c b/generic/tclUtil.c index c658988..869169a 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.57 2005/05/03 18:08:21 dgp Exp $ + * RCS: @(#) $Id: tclUtil.c,v 1.58 2005/05/05 18:38:06 dgp Exp $ */ #include "tclInt.h" @@ -1416,43 +1416,6 @@ Tcl_StringCaseMatch(str, 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 diff --git a/generic/tclVar.c b/generic/tclVar.c index 0b5497f..314f958 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.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: tclVar.c,v 1.104 2005/04/16 19:17:34 msofer Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.105 2005/05/05 18:38:06 dgp Exp $ */ #include "tclInt.h" @@ -2771,7 +2771,23 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) TclNewObj(nameLstPtr); Tcl_IncrRefCount(nameLstPtr); - + if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + if (hPtr == NULL) { + goto searchDone; + } + varPtr2 = (Var *) Tcl_GetHashValue(hPtr); + if (TclIsVarUndefined(varPtr2)) { + goto searchDone; + } + result = Tcl_ListObjAppendElement(interp, nameLstPtr, + Tcl_NewStringObj(pattern, -1)); + if (result != TCL_OK) { + Tcl_DecrRefCount(nameLstPtr); + return result; + } + goto searchDone; + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -2792,6 +2808,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) return result; } } +searchDone: /* * Make sure the Var structure of the array is not removed by @@ -2881,6 +2898,19 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } } TclNewObj(resultPtr); + if ((((enum options) mode) == OPT_GLOB) && (pattern != NULL) + && TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + if ((hPtr != NULL) + && !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr)) + && (result = Tcl_ListObjAppendElement(interp, + resultPtr, Tcl_NewStringObj(pattern, -1))) != TCL_OK) { + Tcl_DecrRefCount(resultPtr); + return result; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { varPtr2 = (Var *) Tcl_GetHashValue(hPtr); @@ -3059,6 +3089,15 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv) } } else { pattern = TclGetString(objv[3]); + if (TclMatchIsTrivial(pattern)) { + hPtr = Tcl_FindHashEntry(varPtr->value.tablePtr, pattern); + result = TCL_OK; + (hPtr != NULL) + && !TclIsVarUndefined((Var *) Tcl_GetHashValue(hPtr)) + && (result + = TclObjUnsetVar2(interp, varNamePtr, pattern, 0)); + return result; + } for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { |