diff options
Diffstat (limited to 'generic/tclNamesp.c')
| -rw-r--r-- | generic/tclNamesp.c | 120 |
1 files changed, 66 insertions, 54 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index d4ace43..e159f98 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -18,7 +18,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * SCCS: @(#) tclNamesp.c 1.29 97/08/04 09:32:38 + * SCCS: @(#) tclNamesp.c 1.38 98/02/04 16:21:40 */ #include "tclInt.h" @@ -37,7 +37,8 @@ * unique id for each namespace. */ -static long numNsCreated = 0; +static long numNsCreated = 0; +static Tcl_Mutex nsMutex; /* * Data structure used as the ClientData of imported commands: commands @@ -156,39 +157,28 @@ Tcl_ObjType tclNsNameType = { UpdateStringOfNsName, /* updateStringProc */ SetNsNameFromAny /* setFromAnyProc */ }; - -/* - * Boolean flag indicating whether or not the namespName object - * type has been registered with the Tcl compiler. - */ - -static int nsInitialized = 0; /* *---------------------------------------------------------------------- * - * TclInitNamespaces -- + * TclInitNamespaceSubsystem -- * - * Called when any interpreter is created to make sure that - * things are properly set up for namespaces. + * This procedure is called to initialize all the structures that + * are used by namespaces on a per-process basis. * * Results: * None. * * Side effects: - * On the first call, the namespName object type is registered - * with the Tcl compiler. + * The namespace object type is registered with the Tcl compiler. * *---------------------------------------------------------------------- */ void -TclInitNamespaces() +TclInitNamespaceSubsystem() { - if (!nsInitialized) { - Tcl_RegisterObjType(&tclNsNameType); - nsInitialized = 1; - } + Tcl_RegisterObjType(&tclNsNameType); } /* @@ -526,7 +516,6 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) * count of namespaces created. */ - numNsCreated++; nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); @@ -536,7 +525,10 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) nsPtr->deleteProc = deleteProc; nsPtr->parentPtr = parentPtr; Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); + Tcl_MutexLock(&nsMutex); + numNsCreated++; nsPtr->nsId = numNsCreated; + Tcl_MutexUnlock(&nsMutex); nsPtr->interp = interp; nsPtr->flags = 0; nsPtr->activationCount = 0; @@ -1113,7 +1105,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) char *simplePattern, *cmdName; register Tcl_HashEntry *hPtr; Tcl_HashSearch search; - Command *cmdPtr; + Command *cmdPtr, *realCmdPtr; ImportRef *refPtr; Tcl_Command importedCmd; ImportedCmdData *dataPtr; @@ -1217,8 +1209,30 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) Tcl_DStringAppend(&ds, "::", 2); } Tcl_DStringAppend(&ds, cmdName, -1); - + + /* + * Check whether creating the new imported command in the + * current namespace would create a cycle of imported->real + * command references that also would destroy an existing + * "real" command already in the current namespace. + */ + cmdPtr = (Command *) Tcl_GetHashValue(hPtr); + if (cmdPtr->deleteProc == DeleteImportedCmd) { + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + if ((realCmdPtr != NULL) + && (realCmdPtr->nsPtr == currNsPtr) + && (Tcl_FindHashEntry(&currNsPtr->cmdTable, + cmdName) != NULL)) { + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), + "import pattern \"", pattern, + "\" would create a loop containing command \"", + Tcl_DStringValue(&ds), "\"", (char *) NULL); + return TCL_ERROR; + } + } + dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_CreateObjCommand(interp, @@ -2440,8 +2454,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace children command", (char *) NULL); return TCL_ERROR; } @@ -2457,7 +2470,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv) Tcl_DStringInit(&buffer); if (objc == 4) { - char *name = Tcl_GetStringFromObj(objv[3], (int *) NULL); + char *name = Tcl_GetString(objv[3]); if ((*name == ':') && (*(name+1) == ':')) { pattern = name; @@ -2691,13 +2704,12 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) */ for (i = 2; i < objc; i++) { - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, /*flags*/ 0); if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[i], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[i]), "\" in namespace delete command", (char *) NULL); return TCL_ERROR; } @@ -2708,7 +2720,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv) */ for (i = 2; i < objc; i++) { - name = Tcl_GetStringFromObj(objv[i], (int *) NULL); + name = Tcl_GetString(objv[i]); namespacePtr = Tcl_FindNamespace(interp, name, (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); if (namespacePtr == NULL) { @@ -2799,14 +2811,19 @@ NamespaceEvalCmd(dummy, interp, objc, objv) } if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObj(interp, objv[3], 0); } else { objPtr = Tcl_ConcatObj(objc-3, objv+3); - result = Tcl_EvalObj(interp, objPtr); - Tcl_DecrRefCount(objPtr); /* we're done with the object */ + + /* + * Tcl_EvalObj will delete the object when it decrements its + * refcount after eval'ing it. + */ + + result = Tcl_EvalObj(interp, objPtr, TCL_EVAL_DIRECT); } if (result == TCL_ERROR) { - char msg[256]; + char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", namespacePtr->fullName, interp->errorLine); @@ -2881,7 +2898,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + string = Tcl_GetString(objv[firstArg]); if (strcmp(string, "-clear") == 0) { resetListFirst = 1; firstArg++; @@ -2914,7 +2931,7 @@ NamespaceExportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, ((i == firstArg)? resetListFirst : 0)); if (result != TCL_OK) { @@ -2970,7 +2987,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv) } for (i = 2; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); if (result != TCL_OK) { return result; @@ -3040,7 +3057,7 @@ NamespaceImportCmd(dummy, interp, objc, objv) firstArg = 2; if (firstArg < objc) { - string = Tcl_GetStringFromObj(objv[firstArg], (int *) NULL); + string = Tcl_GetString(objv[firstArg]); if ((*string == '-') && (strcmp(string, "-force") == 0)) { allowOverwrite = 1; firstArg++; @@ -3052,7 +3069,7 @@ NamespaceImportCmd(dummy, interp, objc, objv) */ for (i = firstArg; i < objc; i++) { - pattern = Tcl_GetStringFromObj(objv[i], (int *) NULL); + pattern = Tcl_GetString(objv[i]); result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, allowOverwrite); if (result != TCL_OK) { @@ -3126,8 +3143,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) } if (namespacePtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in inscope namespace command", (char *) NULL); return TCL_ERROR; } @@ -3150,7 +3166,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) */ if (objc == 4) { - result = Tcl_EvalObj(interp, objv[3]); + result = Tcl_EvalObj(interp, objv[3], 0); } else { Tcl_Obj *concatObjv[2]; register Tcl_Obj *listPtr, *cmdObjPtr; @@ -3167,13 +3183,11 @@ NamespaceInscopeCmd(dummy, interp, objc, objv) concatObjv[0] = objv[3]; concatObjv[1] = listPtr; cmdObjPtr = Tcl_ConcatObj(2, concatObjv); - result = Tcl_EvalObj(interp, cmdObjPtr); - - Tcl_DecrRefCount(cmdObjPtr); /* we're done with the cmd object */ + result = Tcl_EvalObj(interp, cmdObjPtr, TCL_EVAL_DIRECT); Tcl_DecrRefCount(listPtr); /* we're done with the list object */ } if (result == TCL_ERROR) { - char msg[256]; + char msg[256 + TCL_INTEGER_SPACE]; sprintf(msg, "\n (in namespace inscope \"%.200s\" script line %d)", @@ -3235,8 +3249,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv) command = Tcl_GetCommandFromObj(interp, objv[2]); if (command == (Tcl_Command) NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "invalid command name \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "invalid command name \"", Tcl_GetString(objv[2]), "\"", (char *) NULL); return TCL_ERROR; } @@ -3295,8 +3308,7 @@ NamespaceParentCmd(dummy, interp, objc, objv) } if (nsPtr == NULL) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), - "unknown namespace \"", - Tcl_GetStringFromObj(objv[2], (int *) NULL), + "unknown namespace \"", Tcl_GetString(objv[2]), "\" in namespace parent command", (char *) NULL); return TCL_ERROR; } @@ -3362,7 +3374,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) * the start of the last "::" qualifier. */ - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -3428,7 +3440,7 @@ NamespaceTailCmd(dummy, interp, objc, objv) * last "::" qualifier. */ - name = Tcl_GetStringFromObj(objv[2], (int *) NULL); + name = Tcl_GetString(objv[2]); for (p = name; *p != '\0'; p++) { /* empty body */ } @@ -3492,7 +3504,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) argIndex = 2; lookup = 0; /* assume command lookup by default */ - arg = Tcl_GetStringFromObj(objv[2], (int *) NULL); + arg = Tcl_GetString(objv[2]); if (*arg == '-') { if (strncmp(arg, "-command", 8) == 0) { lookup = 0; @@ -3517,7 +3529,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) break; case 1: /* -variable */ - arg = Tcl_GetStringFromObj(objv[argIndex], (int *) NULL); + arg = Tcl_GetString(objv[argIndex]); variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, /*flags*/ 0); if (variable != (Tcl_Var) NULL) { @@ -3657,7 +3669,7 @@ SetNsNameFromAny(interp, objPtr) name = objPtr->bytes; if (name == NULL) { - name = Tcl_GetStringFromObj(objPtr, (int *) NULL); + name = Tcl_GetString(objPtr); } /* |