summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog13
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclCmdIL.c9
-rw-r--r--generic/tclCompCmds.c15
-rw-r--r--generic/tclDictObj.c26
-rw-r--r--generic/tclIO.c15
-rw-r--r--generic/tclInt.decls8
-rw-r--r--generic/tclInt.h15
-rw-r--r--generic/tclIntDecls.h15
-rw-r--r--generic/tclNamesp.c217
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclUtil.c39
-rw-r--r--generic/tclVar.c43
13 files changed, 266 insertions, 164 deletions
diff --git a/ChangeLog b/ChangeLog
index 1b1b99d..2c02d31 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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)) {
generated by cgit v0.12 at 2024-11-12 23:17:20 (GMT)