summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c184
1 files changed, 102 insertions, 82 deletions
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index d3fe249..b01cb84 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,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.10 1999/02/03 21:28:01 stanton Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.11 1999/04/16 00:46:50 stanton Exp $
*/
#include "tclInt.h"
@@ -34,7 +34,7 @@
#define FIND_ONLY_NS 0x1000
/*
- * Initial sise of stack allocated space for tail list - used when resetting
+ * Initial size of stack allocated space for tail list - used when resetting
* shadowed command references in the functin: TclResetShadowedCmdRefs.
*/
@@ -46,6 +46,7 @@
*/
static long numNsCreated = 0;
+TCL_DECLARE_MUTEX(nsMutex)
/*
* This structure contains a cached pointer to a namespace that is the
@@ -149,39 +150,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);
}
/*
@@ -298,8 +288,8 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
} else {
nsPtr = (Namespace *) namespacePtr;
if (nsPtr->flags & NS_DEAD) {
- panic("Trying to push call frame for dead namespace");
- /*NOTREACHED*/
+ panic("Trying to push call frame for dead namespace");
+ /*NOTREACHED*/
}
}
@@ -479,9 +469,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
* Find the parent for the new namespace.
*/
- TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
- /*flags*/ CREATE_NS_IF_UNKNOWN, &parentPtr, &dummy1Ptr,
- &dummy2Ptr, &simpleName);
+ TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
+ /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
+ &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
/*
* If the unqualified name at the end is empty, there were trailing
@@ -512,7 +502,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));
@@ -522,7 +511,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;
@@ -953,7 +945,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr,
+ &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1105,7 +1098,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 autoCmd, importedCmd;
ImportedCmdData *dataPtr;
@@ -1165,7 +1158,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
+ &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1238,8 +1232,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,
@@ -1327,7 +1343,8 @@ Tcl_ForgetImport(interp, namespacePtr, pattern)
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ 0, &importNsPtr, &dummyPtr, &actualCtxPtr, &simplePattern);
+ /*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
+ &actualCtxPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1540,16 +1557,21 @@ DeleteImportedCmd(clientData)
* final component is stored in *simpleNamePtr.
*
* Results:
- * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
- * namespaces which represent the last (containing) namespace in the
- * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
- * to NULL, then the search along that path failed. The procedure also
- * stores a pointer to the simple name of the final component in
- * *simpleNamePtr. If the qualified name is "::" or was treated as a
- * namespace reference (FIND_ONLY_NS), the procedure stores a pointer
- * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
+ * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
+ * namespaces which represent the last (containing) namespace in the
+ * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
+ * to NULL, then the search along that path failed. The procedure also
+ * stores a pointer to the simple name of the final component in
+ * *simpleNamePtr. If the qualified name is "::" or was treated as a
+ * namespace reference (FIND_ONLY_NS), the procedure stores a pointer
+ * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
* *simpleNamePtr to point to an empty string.
*
+ * If there is an error, this procedure returns TCL_ERROR. If "flags"
+ * contains TCL_LEAVE_ERR_MSG, an error message is returned in the
+ * interpreter's result object. Otherwise, the interpreter's result
+ * object is left unchanged.
+ *
* *actualCxtPtrPtr is set to the actual context namespace. It is
* set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
* is NULL, it is set to the current namespace context.
@@ -1558,8 +1580,8 @@ DeleteImportedCmd(clientData)
* this function always returns TCL_OK.
*
* Side effects:
- * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
- * created.
+ * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
+ * created.
*
*----------------------------------------------------------------------
*/
@@ -1709,7 +1731,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
*altNsPtrPtr = altNsPtr;
*simpleNamePtr = start;
Tcl_DStringFree(&buffer);
- return TCL_OK;
+ return TCL_OK;
}
} else {
/*
@@ -1739,7 +1761,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
} else if (flags & CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame frame;
- (void) Tcl_PushCallFrame(interp, &frame,
+ (void) Tcl_PushCallFrame(interp, &frame,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
@@ -1747,7 +1769,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
Tcl_PopCallFrame(interp);
if (nsPtr == NULL) {
- panic("Could not create namespace '%s'", nsName);
+ panic("Could not create namespace '%s'", nsName);
}
} else { /* namespace not found and wasn't created */
nsPtr = NULL;
@@ -1858,8 +1880,8 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
-
+ (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
@@ -1971,7 +1993,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the command in the command table of its namespace.
@@ -2101,7 +2123,7 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the variable in the variable table of its namespace.
@@ -2416,8 +2438,8 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
NSEvalIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
- } index;
- int result;
+ };
+ int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
@@ -2530,8 +2552,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;
}
@@ -2547,7 +2568,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;
@@ -2781,13 +2802,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;
}
@@ -2798,7 +2818,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, /* flags */ 0);
if (namespacePtr) {
@@ -2888,14 +2908,19 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
}
if (objc == 4) {
- result = Tcl_EvalObj(interp, objv[3]);
+ result = Tcl_EvalObjEx(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_EvalObjEx(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);
@@ -2970,7 +2995,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++;
@@ -3003,7 +3028,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) {
@@ -3059,7 +3084,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;
@@ -3129,7 +3154,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++;
@@ -3141,7 +3166,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) {
@@ -3215,8 +3240,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;
}
@@ -3239,7 +3263,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
*/
if (objc == 4) {
- result = Tcl_EvalObj(interp, objv[3]);
+ result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
Tcl_Obj *concatObjv[2];
register Tcl_Obj *listPtr, *cmdObjPtr;
@@ -3256,13 +3280,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_EvalObjEx(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)",
@@ -3324,8 +3346,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;
}
@@ -3384,8 +3405,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;
}
@@ -3451,7 +3471,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 */
}
@@ -3517,7 +3537,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 */
}
@@ -3581,7 +3601,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;
@@ -3606,7 +3626,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) {
@@ -3745,7 +3765,7 @@ SetNsNameFromAny(interp, objPtr)
name = objPtr->bytes;
if (name == NULL) {
- name = Tcl_GetStringFromObj(objPtr, (int *) NULL);
+ name = Tcl_GetString(objPtr);
}
/*
@@ -3756,7 +3776,7 @@ SetNsNameFromAny(interp, objPtr)
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
- /*flags*/ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
+ FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*
* If we found a namespace, then create a new ResolvedNsName structure
generated by cgit v0.12 at 2024-11-09 20:41:08 (GMT)