summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog16
-rw-r--r--doc/info.n13
-rw-r--r--doc/namespace.n36
-rw-r--r--generic/tclBasic.c5
-rw-r--r--generic/tclCmdIL.c130
-rw-r--r--generic/tclInt.h30
-rw-r--r--generic/tclNamesp.c374
-rw-r--r--generic/tclResolve.c5
-rw-r--r--tests/info.test3
-rw-r--r--tests/namespace.test389
10 files changed, 953 insertions, 48 deletions
diff --git a/ChangeLog b/ChangeLog
index 8c4dbbc..dd49dbd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,19 @@
+2005-05-30 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ TIP #229 IMPLEMENTATION
+
+ * generic/tclNamesp.c (Tcl_FindCommand, TclResetShadowedCmdRefs)
+ (NamespacePathCmd, SetNsPath, UnlinkNsPath, TclInvalidateNsPath):
+ Implementation of the [namespace path] command and the command
+ name resolution engine.
+ * doc/info.n, doc/namespace.n: Doc updates.
+ * tests/namespace.test (namespace-51.*): Test updates.
+ * generic/tclResolve.c (BumpCmdRefEpochs, Tcl_SetNamespaceResolvers):
+ * generic/tclBasic.c (Tcl_CreateCommand, Tcl_CreateObjCommand):
+ Ensure that people don't see stale paths.
+ * generic/tclInt.h (Namespace, NamespacePathEntry): Structure defs.
+ * generic/tclCmdIL.c (InfoCommandsCmd): Updates to [info commands].
+
2005-05-26 Daniel Steffen <das@users.sourceforge.net>
* macosx/Makefile: moved & corrected EMBEDDED_BUILD check.
diff --git a/doc/info.n b/doc/info.n
index 1fc9f8b..8bfee19 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -7,7 +7,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: info.n,v 1.16 2005/05/10 18:34:00 kennykb Exp $
+'\" RCS: @(#) $Id: info.n,v 1.17 2005/05/30 00:04:45 dkf Exp $
'\"
.so man.macros
.TH info n 8.4 Tcl "Tcl Built-In Commands"
@@ -40,7 +40,10 @@ in this interpreter.
.TP
\fBinfo commands \fR?\fIpattern\fR?
If \fIpattern\fR isn't specified,
-returns a list of names of all the Tcl commands in the current namespace,
+'\" Do not move this .VS above the .TP
+.VS 8.5
+returns a list of names of all the Tcl commands visible
+(i.e. executable without using a qualified name) to the current namespace,
including both the built-in commands written in C and
the command procedures defined using the \fBproc\fR command.
If \fIpattern\fR is specified,
@@ -53,7 +56,11 @@ and may have pattern matching special characters
at the end to specify a set of commands in that namespace.
If \fIpattern\fR is a qualified name,
the resulting list of command names has each one qualified with the name
-of the specified namespace.
+of the specified namespace, and only the commands defined in the named
+namespace are returned.
+'\" Technically, most of this hasn't changed; that's mostly just the
+'\" way it always worked. Hardly anyone knew that though.
+.VE 8.5
.TP
\fBinfo complete \fIcommand\fR
Returns 1 if \fIcommand\fR is a complete Tcl command in the sense of
diff --git a/doc/namespace.n b/doc/namespace.n
index 48c570a..60bd8e8 100644
--- a/doc/namespace.n
+++ b/doc/namespace.n
@@ -2,11 +2,12 @@
'\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\" Copyright (c) 2000 Scriptics Corporation.
+'\" Copyright (c) 2004-2005 Donal K. Fellows.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: namespace.n,v 1.17 2005/05/12 16:23:20 dgp Exp $
+'\" RCS: @(#) $Id: namespace.n,v 1.18 2005/05/30 00:04:45 dkf Exp $
'\"
.so man.macros
.TH namespace n 8.5 Tcl "Tcl Built-In Commands"
@@ -216,6 +217,17 @@ for namespace \fInamespace\fR.
If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.
.TP
+\fBnamespace path\fR ?\fInamespaceList\fR?
+'\" Should really have the .TP inside the .VS, but that triggers a groff bug
+.VS 8.5
+Returns the command resolution path of the current namespace. If
+\fInamespaceList\fR is specified as a list of named namespaces, the
+current namespace's command resolution path is set to those namespaces
+and returns the empty list. The default command resolution path is
+always empty. See the section \fBNAME RESOLUTION\fR below for an
+explanation of the rules regarding name resolution.
+.VE 8.5
+.TP
\fBnamespace qualifiers\fR \fIstring\fR
Returns any leading namespace qualifiers for \fIstring\fR.
Qualifiers are namespace names separated by double colons (\fB::\fR).
@@ -387,10 +399,18 @@ there is no question about what command, variable, or namespace
you mean.
However, if the name does not start with a \fB::\fR
(i.e., is \fIrelative\fR),
-Tcl follows a fixed rule for looking it up:
-Command and variable names are always resolved
+Tcl follows basic rules for looking it up:
+Variable names are always resolved
by looking first in the current namespace,
and then in the global namespace.
+.VS 8.5
+Command names are also always resolved by looking in the current
+namespace first. If not found there, they are searched for in every
+namespace on the current namespace's command path (which is empty by
+default). If not found there, command names are looked up in the
+global namespace (or, failing that, are processed by the \fBunknown\fR
+command.)
+.VE 8.5
Namespace names, on the other hand, are always resolved
by looking in only the current namespace.
.PP
@@ -764,10 +784,16 @@ Create a namespace containing a variable and an exported command:
Call the command defined in the previous example in various ways.
.CS
# Direct call
-foo::grill
+::foo::grill
+
+# Use the command resolution path to find the name
+\fBnamespace eval\fR boo {
+ \fBnamespace path\fR ::foo
+ grill
+}
# Import into current namespace, then call local alias
-namespace import foo::grill
+\fBnamespace import\fR foo::grill
grill
# Create two ensembles, one with the default name and one with a
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index e526dc2..144b2f7 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.157 2005/05/25 16:13:17 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.158 2005/05/30 00:04:45 dkf Exp $
*/
#include "tclInt.h"
@@ -1579,6 +1579,7 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
*/
TclInvalidateNsCmdLookup(nsPtr);
+ TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
@@ -1703,6 +1704,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
}
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ TclInvalidateNsPath(nsPtr);
if (!new) {
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
@@ -1749,6 +1751,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
*/
TclInvalidateNsCmdLookup(nsPtr);
+ TclInvalidateNsPath(nsPtr);
}
cmdPtr = (Command *) ckalloc(sizeof(Command));
Tcl_SetHashValue(hPtr, cmdPtr);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 7f67180..b68f7ba 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -11,11 +11,12 @@
* Copyright (c) 1994-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
+ * Copyright (c) 2005 Donal K. Fellows.
*
* 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.74 2005/05/10 18:34:08 kennykb Exp $
+ * RCS: @(#) $Id: tclCmdIL.c,v 1.75 2005/05/30 00:04:46 dkf Exp $
*/
#include "tclInt.h"
@@ -712,6 +713,7 @@ InfoCommandsCmd(dummy, interp, objc, objv)
Tcl_Obj *listPtr, *elemObjPtr;
int specificNsInPattern = 0; /* Init. to avoid compiler warning. */
Tcl_Command cmd;
+ int i;
/*
* Get the pattern and find the "effective namespace" in which to
@@ -779,16 +781,43 @@ InfoCommandsCmd(dummy, interp, objc, objv)
elemObjPtr = Tcl_NewStringObj(cmdName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
- } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
- entryPtr = Tcl_FindHashEntry(&globalNsPtr->cmdTable,
- simplePattern);
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
+ }
+ if ((nsPtr != globalNsPtr) && !specificNsInPattern) {
+ Tcl_HashTable *tablePtr;
+
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;
+
+ if (pathNsPtr == NULL) {
+ continue;
+ }
+ tablePtr = &pathNsPtr->cmdTable;
+ entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
+ if (entryPtr != NULL) {
+ break;
+ }
+ }
+ if (entryPtr == NULL) {
+ tablePtr = &globalNsPtr->cmdTable;
+ entryPtr = Tcl_FindHashEntry(tablePtr, simplePattern);
+ }
if (entryPtr != NULL) {
- cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ cmdName = Tcl_GetHashKey(tablePtr, entryPtr);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj(cmdName, -1));
+ Tcl_SetObjResult(interp, listPtr);
+ return TCL_OK;
}
}
- } else {
+ } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) {
+ /*
+ * The pattern is non-trivial, but either there is no explicit
+ * path or there is an explicit namespace in the pattern. In
+ * both cases, the old matching scheme is perfect.
+ */
+
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
while (entryPtr != NULL) {
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
@@ -828,6 +857,95 @@ InfoCommandsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_NextHashEntry(&search);
}
}
+ } else {
+ /*
+ * The pattern is non-trivial (can match more than one command
+ * name), there is an explicit path, and there is no explicit
+ * namespace in the pattern. This means that we have to
+ * traverse the path to discover all the commands defined.
+ */
+
+ Tcl_HashTable addedCommandsTable;
+ int isNew;
+ int foundGlobal = (nsPtr == globalNsPtr);
+
+ /*
+ * We keep a hash of the objects already added to the result
+ * list.
+ */
+ Tcl_InitObjHashTable(&addedCommandsTable);
+
+ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ (void) Tcl_CreateHashEntry(&addedCommandsTable,
+ (char *)elemObjPtr, &isNew);
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+
+ /*
+ * Search the path next.
+ */
+
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ Namespace *pathNsPtr = nsPtr->commandPathArray[i].nsPtr;
+
+ if (pathNsPtr == NULL) {
+ continue;
+ }
+ if (pathNsPtr == globalNsPtr) {
+ foundGlobal = 1;
+ }
+ entryPtr = Tcl_FirstHashEntry(&pathNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&pathNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ (void) Tcl_CreateHashEntry(&addedCommandsTable,
+ (char *) elemObjPtr, &isNew);
+ if (isNew) {
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ } else {
+ TclDecrRefCount(elemObjPtr);
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
+
+ /*
+ * If the effective namespace isn't the global :: namespace, and a
+ * specific namespace wasn't requested in the pattern, then add in
+ * all global :: commands that match the simple pattern. Of course,
+ * we add in only those commands that aren't hidden by a command in
+ * the effective namespace.
+ */
+
+ if (!foundGlobal) {
+ entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search);
+ while (entryPtr != NULL) {
+ cmdName = Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr);
+ if ((simplePattern == NULL)
+ || Tcl_StringMatch(cmdName, simplePattern)) {
+ elemObjPtr = Tcl_NewStringObj(cmdName, -1);
+ if (Tcl_FindHashEntry(&addedCommandsTable,
+ (char *) elemObjPtr) == NULL) {
+ Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr);
+ } else {
+ TclDecrRefCount(elemObjPtr);
+ }
+ }
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ }
+
+ Tcl_DeleteHashTable(&addedCommandsTable);
}
Tcl_SetObjResult(interp, listPtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a739fe8..7efd7c1 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.231 2005/05/23 20:19:45 das Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.232 2005/05/30 00:04:47 dkf Exp $
*/
#ifndef _TCLINT
@@ -131,6 +131,7 @@ typedef struct Tcl_ResolverInfo {
*/
typedef struct Tcl_Ensemble Tcl_Ensemble;
+typedef struct NamespacePathEntry NamespacePathEntry;
/*
* The structure below defines a namespace.
@@ -233,9 +234,35 @@ typedef struct Namespace {
Tcl_Ensemble *ensembles; /* List of structures that contain the details
* of the ensembles that are implemented on
* top of this namespace. */
+ int commandPathLength; /* The length of the explicit path. */
+ NamespacePathEntry *commandPathArray;
+ /* The explicit path of the namespace as an
+ * array. */
+ NamespacePathEntry *commandPathSourceList;
+ /* Linked list of path entries that point to
+ * this namespace. */
} Namespace;
/*
+ * An entry on a namespace's command resolution path.
+ */
+
+struct NamespacePathEntry {
+ Namespace *nsPtr; /* What does this path entry point to? If it
+ *is NULL, this path entry points is redundant
+ * and should be skipped. */
+ Namespace *creatorNsPtr; /* Where does this path entry point from? This
+ * allows for efficient invalidation of
+ * references when the path entry's target
+ * updates its current list of defined
+ * commands. */
+ NamespacePathEntry *prevPtr, *nextPtr;
+ /* Linked list pointers or NULL at either end
+ * of the list that hangs off Namespace's
+ * commandPathSourceList field. */
+};
+
+/*
* Flags used to represent the status of a namespace:
*
* NS_DYING - 1 means Tcl_DeleteNamespace has been called to delete the
@@ -2442,6 +2469,7 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrWideVar _ANSI_ARGS_((Tcl_Interp *interp,
Var *varPtr, Var *arrayPtr, CONST char *part1,
CONST char *part2, CONST Tcl_WideInt i,
CONST int flags));
+MODULE_SCOPE void TclInvalidateNsPath _ANSI_ARGS_((Namespace *nsPtr));
/*
*----------------------------------------------------------------
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 61329d3..c49bd43 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.75 2005/05/19 22:49:01 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.76 2005/05/30 00:04:48 dkf Exp $
*/
#include "tclInt.h"
@@ -242,6 +242,9 @@ static int NamespaceOriginCmd _ANSI_ARGS_((
static int NamespaceParentCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
+static int NamespacePathCmd _ANSI_ARGS_((
+ ClientData dummy, Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[]));
static int NamespaceQualifiersCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
@@ -270,6 +273,9 @@ static void FreeEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static void DupEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
static void StringOfEnsembleCmdRep _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void UnlinkNsPath _ANSI_ARGS_((Namespace *nsPtr));
+static void SetNsPath _ANSI_ARGS_((Namespace *nsPtr,
+ int pathLength, Tcl_Namespace *pathAry[]));
/*
* This structure defines a Tcl object type that contains a
@@ -844,6 +850,9 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
nsPtr->compiledVarResProc = NULL;
nsPtr->exportLookupEpoch = 0;
nsPtr->ensembles = NULL;
+ nsPtr->commandPathLength = 0;
+ nsPtr->commandPathArray = NULL;
+ nsPtr->commandPathSourceList = NULL;
if (parentPtr != NULL) {
entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
@@ -1065,6 +1074,22 @@ TclTeardownNamespace(nsPtr)
nsPtr->parentPtr = NULL;
/*
+ * Delete the namespace path if one is installed.
+ */
+
+ if (nsPtr->commandPathLength != 0) {
+ UnlinkNsPath(nsPtr);
+ nsPtr->commandPathLength = 0;
+ }
+ if (nsPtr->commandPathSourceList != NULL) {
+ NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+ do {
+ nsPathPtr->nsPtr = NULL;
+ nsPathPtr = nsPathPtr->nextPtr;
+ } while (nsPathPtr != NULL);
+ }
+
+ /*
* Delete all the child namespaces.
*
* BE CAREFUL: When each child is deleted, it will divorce
@@ -2309,15 +2334,11 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
* ignored. */
{
Interp *iPtr = (Interp*)interp;
-
- ResolverScheme *resPtr;
- Namespace *nsPtr[2], *cxtNsPtr;
- CONST char *simpleName;
+ Namespace *cxtNsPtr;
register Tcl_HashEntry *entryPtr;
register Command *cmdPtr;
- register int search;
+ CONST char *simpleName;
int result;
- Tcl_Command cmd;
/*
* If this namespace has a command resolver, then give it first
@@ -2326,7 +2347,7 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
* procedures may return a Tcl_Command value, they may signal
* to continue onward, or they may signal an error.
*/
- if ((flags & TCL_GLOBAL_ONLY) != 0) {
+ if (flags & TCL_GLOBAL_ONLY) {
cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
} else if (contextNsPtr != NULL) {
cxtNsPtr = (Namespace *) contextNsPtr;
@@ -2335,7 +2356,8 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
}
if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
- resPtr = iPtr->resolverPtr;
+ ResolverScheme *resPtr = iPtr->resolverPtr;
+ Tcl_Command cmd;
if (cxtNsPtr->cmdResProc) {
result = (*cxtNsPtr->cmdResProc)(interp, name,
@@ -2363,33 +2385,90 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags)
* Find the namespace(s) that contain the command.
*/
- TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
- flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
-
- /*
- * Look for the command in the command table of its namespace.
- * Be sure to check both possible search paths: from the specified
- * namespace context and from the global namespace.
- */
-
cmdPtr = NULL;
- for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
- if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
- entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
- simpleName);
+ if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)) {
+ int i;
+ Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
+
+ (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
+ TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
+ &simpleName);
+ if (realNsPtr != NULL && simpleName != NULL) {
+ entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
if (entryPtr != NULL) {
cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
}
}
+
+ /*
+ * Next, check along the path.
+ */
+
+ for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
+ pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
+ if (pathNsPtr == NULL) {
+ continue;
+ }
+ (void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
+ TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
+ &simpleName);
+ if (realNsPtr != NULL && simpleName != NULL) {
+ entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
+ if (entryPtr != NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ }
+ }
+ }
+
+ /*
+ * If we've still not found the command, look in the global
+ * namespace as a last resort.
+ */
+
+ if (cmdPtr == NULL) {
+ (void) TclGetNamespaceForQualName(interp, name, NULL,
+ TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
+ &simpleName);
+ if (realNsPtr != NULL && simpleName != NULL) {
+ entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
+ if (entryPtr != NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ }
+ }
+ }
+ } else {
+ Namespace *nsPtr[2];
+ register int search;
+
+ TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
+ flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
+
+ /*
+ * Look for the command in the command table of its namespace.
+ * Be sure to check both possible search paths: from the
+ * specified namespace context and from the global namespace.
+ */
+
+ for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
+ if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
+ entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
+ simpleName);
+ if (entryPtr != NULL) {
+ cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+ }
+ }
+ }
}
+
if (cmdPtr != NULL) {
return (Tcl_Command) cmdPtr;
- } else if (flags & TCL_LEAVE_ERR_MSG) {
+ }
+
+ if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown command \"", name,
"\"", (char *) NULL);
}
-
return (Tcl_Command) NULL;
}
@@ -2628,6 +2707,7 @@ TclResetShadowedCmdRefs(interp, newCmdPtr)
hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
if (hPtr != NULL) {
nsPtr->cmdRefEpoch++;
+ TclInvalidateNsPath(nsPtr);
/*
* If the shadowed command was compiled to bytecodes, we
@@ -2831,13 +2911,13 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
static CONST char *subCmds[] = {
"children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
- "inscope", "origin", "parent", "qualifiers",
+ "inscope", "origin", "parent", "path", "qualifiers",
"tail", "which", (char *) NULL
};
enum NSSubCmdIdx {
NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
- NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
+ NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
};
int index, result;
@@ -2897,6 +2977,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
case NSParentIdx:
result = NamespaceParentCmd(clientData, interp, objc, objv);
break;
+ case NSPathIdx:
+ result = NamespacePathCmd(clientData, interp, objc, objv);
+ break;
case NSQualifiersIdx:
result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
break;
@@ -3906,6 +3989,245 @@ NamespaceParentCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
+ * NamespacePathCmd --
+ *
+ * Invoked to implement the "namespace path" command that reads
+ * and writes the current namespace's command resolution path.
+ * Has one optional argument: if present, it is a list of named
+ * namespaces to set the path to, and if absent, the current path
+ * should be returned. Handles the following syntax:
+ *
+ * namespace path ?nsList?
+ *
+ * Results:
+ * Returns TCL_OK if successful, and TCL_ERROR if anything goes
+ * wrong (most notably if the namespace list contains the name of
+ * something other than a namespace). In the successful-exit
+ * case, may set the interpreter result to the list of names of
+ * the namespaces on the current namespace's path.
+ *
+ * Side effects:
+ * May update the namespace path (triggering a recomputing of all
+ * command names that depend on the namespace for resolution).
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+NamespacePathCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ int i, nsObjc, result = TCL_ERROR;
+ Tcl_Obj **nsObjv;
+ Tcl_Namespace **namespaceList = NULL;
+ Tcl_Namespace *staticNs[4];
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?pathList?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * If no path is given, return the current path.
+ */
+
+ if (objc == 2) {
+ /*
+ * Not a very fast way to compute this, but easy to get right.
+ */
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ if (nsPtr->commandPathArray[i].nsPtr != NULL) {
+ Tcl_AppendElement(interp,
+ nsPtr->commandPathArray[i].nsPtr->fullName);
+ }
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * There is a path given, so parse it into an array of namespace
+ * pointers.
+ */
+
+ if (Tcl_ListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
+ goto badNamespace;
+ }
+ if (nsObjc != 0) {
+ if (nsObjc > 4) {
+ namespaceList = (Tcl_Namespace **)
+ ckalloc(sizeof(Tcl_Namespace *) * nsObjc);
+ } else {
+ namespaceList = staticNs;
+ }
+
+ for (i=0 ; i<nsObjc ; i++) {
+ if (TclGetNamespaceFromObj(interp, nsObjv[i],
+ &namespaceList[i]) != TCL_OK) {
+ goto badNamespace;
+ }
+ if (namespaceList[i] == NULL) {
+ Tcl_AppendResult(interp, "unknown namespace \"",
+ TclGetString(nsObjv[i]), "\"", NULL);
+ goto badNamespace;
+ }
+ }
+ }
+
+ /*
+ * Now we have the list of valid namespaces, install it as the
+ * path.
+ */
+
+ SetNsPath(nsPtr, nsObjc, namespaceList);
+
+ result = TCL_OK;
+ badNamespace:
+ if (namespaceList != NULL && namespaceList != staticNs) {
+ ckfree((char *) namespaceList);
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * SetNsPath --
+ *
+ * Sets the namespace command name resolution path to the given
+ * list of namespaces. If the list is empty (of zero length) the
+ * path is set to empty and the default old-style behaviour of
+ * command name resolution is used.
+ *
+ * Results:
+ * nothing
+ *
+ * Side effects:
+ * Invalidates the command name resolution caches for any command
+ * resolved in the given namespace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+/* EXPOSE ME? */
+static void
+SetNsPath(nsPtr, pathLength, pathAry)
+ Namespace *nsPtr; /* Namespace whose path is to be set. */
+ int pathLength; /* Length of pathAry */
+ Tcl_Namespace *pathAry[]; /* Array of namespaces that are the path. */
+{
+ NamespacePathEntry *tmpPathArray;
+ int i;
+
+ if (pathLength != 0) {
+ tmpPathArray = (NamespacePathEntry *)
+ ckalloc(sizeof(NamespacePathEntry) * pathLength);
+ for (i=0 ; i<pathLength ; i++) {
+ tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
+ tmpPathArray[i].creatorNsPtr = nsPtr;
+ tmpPathArray[i].prevPtr = NULL;
+ tmpPathArray[i].nextPtr =
+ tmpPathArray[i].nsPtr->commandPathSourceList;
+ if (tmpPathArray[i].nextPtr != NULL) {
+ tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i];
+ }
+ tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i];
+ }
+ if (nsPtr->commandPathLength != 0) {
+ UnlinkNsPath(nsPtr);
+ }
+ nsPtr->commandPathArray = tmpPathArray;
+ } else {
+ if (nsPtr->commandPathLength != 0) {
+ UnlinkNsPath(nsPtr);
+ }
+ }
+
+ nsPtr->commandPathLength = pathLength;
+ nsPtr->cmdRefEpoch++;
+ nsPtr->resolverEpoch++;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UnlinkNsPath --
+ *
+ * Delete the given namespace's command name resolution path. Only
+ * call if the path is non-empty. Caller must reset the counter
+ * containing the path size.
+ *
+ * Results:
+ * nothing
+ *
+ * Side effects:
+ * Deletes the array of path entries and unlinks those path entries
+ * from the target namespace's list of interested namespaces.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UnlinkNsPath(nsPtr)
+ Namespace *nsPtr;
+{
+ int i;
+ for (i=0 ; i<nsPtr->commandPathLength ; i++) {
+ NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
+ if (nsPathPtr->prevPtr != NULL) {
+ nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
+ }
+ if (nsPathPtr->nextPtr != NULL) {
+ nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
+ }
+ if (nsPathPtr->nsPtr != NULL) {
+ if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
+ nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
+ }
+ }
+ }
+ ckfree((char *) nsPtr->commandPathArray);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvalidateNsPath --
+ *
+ * Invalidate the name resolution caches for all names looked up
+ * in namespaces whose name path includes the given namespace.
+ *
+ * Results:
+ * nothing
+ *
+ * Side effects:
+ * Increments the command reference epoch in each namespace whose
+ * path includes the given namespace. This causes any cached
+ * resolved names whose root cacheing context starts at that
+ * namespace to be recomputed the next time they are used.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInvalidateNsPath(nsPtr)
+ Namespace *nsPtr;
+{
+ NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
+ while (nsPathPtr != NULL) {
+ if (nsPathPtr->nsPtr != NULL) {
+ nsPathPtr->creatorNsPtr->cmdRefEpoch++;
+ }
+ nsPathPtr = nsPathPtr->nextPtr;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NamespaceQualifiersCmd --
*
* Invoked to implement the "namespace qualifiers" command that returns
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index 4386c3d..49c21ca 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -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: tclResolve.c,v 1.4 2002/01/25 22:01:32 dgp Exp $
+ * RCS: @(#) $Id: tclResolve.c,v 1.5 2005/05/30 00:04:48 dkf Exp $
*/
#include "tclInt.h"
@@ -273,8 +273,8 @@ BumpCmdRefEpochs(nsPtr)
childNsPtr = (Namespace *) Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
+ TclInvalidateNsPath(nsPtr);
}
-
/*
*----------------------------------------------------------------------
@@ -369,6 +369,7 @@ Tcl_SetNamespaceResolvers(namespacePtr, cmdProc, varProc, compiledVarProc)
nsPtr->cmdRefEpoch++;
nsPtr->resolverEpoch++;
+ TclInvalidateNsPath(nsPtr);
}
/*
diff --git a/tests/info.test b/tests/info.test
index 3441a3b..7295750 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -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: info.test,v 1.30 2005/05/25 16:13:17 dgp Exp $
+# RCS: @(#) $Id: info.test,v 1.31 2005/05/30 00:04:48 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -151,6 +151,7 @@ catch {rename _t2_ {}}
test info-4.5 {info commands option} {
list [catch {info commands a b} msg] $msg
} {1 {wrong # args: should be "info commands ?pattern?"}}
+# Also some tests in namespace.test
test info-5.1 {info complete option} {
list [catch {info complete} msg] $msg
diff --git a/tests/namespace.test b/tests/namespace.test
index 9341ecf..c611e9c 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -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: namespace.test,v 1.43 2004/10/29 15:39:10 dkf Exp $
+# RCS: @(#) $Id: namespace.test,v 1.44 2005/05/30 00:04:49 dkf Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -838,7 +838,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
list [catch {namespace wombat {}} msg] $msg
-} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
@@ -945,7 +945,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
test namespace-25.2 {NamespaceEvalCmd, bad args} {
list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, qualifiers, tail, or which}}
+} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
@@ -1956,6 +1956,389 @@ test namespace-50.4 {chained ensembles affect error messages} -body {
rename a {}
}
+test namespace-51.1 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ namespace path ::test_ns_1
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ test_ns_1::test_ns_2::pathtestA
+} -result "global,2,global," -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.2 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ namespace path ::test_ns_1
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ ::test_ns_1::test_ns_2::pathtestA
+} -result "1,2,global,::test_ns_1" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.3 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path ::test_ns_1
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::pathtestB {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global,::test_ns_1" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.4 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path ::test_ns_1
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "global,2,global, 1,2,global,::test_ns_1 global,2,global," -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.5 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ namespace path ::test_ns_1
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ proc pathtestD {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {:: ::test_ns_1}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::test_ns_2::pathtestC {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1}" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.6 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc pathtestA {} {
+ ::return [pathtestB],[pathtestC],[pathtestD],[namespace path]
+ }
+ proc pathtestC {} {
+ ::return 2
+ }
+ namespace path ::test_ns_1
+ }
+ proc pathtestB {} {
+ return 1
+ }
+ proc pathtestC {} {
+ return 1
+ }
+ proc pathtestD {} {
+ return 1
+ }
+ }
+ proc ::pathtestB {} {
+ return global
+ }
+ proc ::pathtestD {} {
+ return global
+ }
+ set result [::test_ns_1::test_ns_2::pathtestA]
+ namespace eval ::test_ns_1::test_ns_2 {
+ namespace path {:: ::test_ns_1}
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ rename ::test_ns_1::test_ns_2::pathtestC {}
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+ proc ::pathtestC {} {
+ return global
+ }
+ lappend result [::test_ns_1::test_ns_2::pathtestA]
+} -result "1,2,1,::test_ns_1 {global,2,global,:: ::test_ns_1} {global,1,global,:: ::test_ns_1} {global,global,global,:: ::test_ns_1}" -cleanup {
+ namespace delete ::test_ns_1
+ catch {rename ::pathtestB {}}
+ catch {rename ::pathtestD {}}
+}
+test namespace-51.7 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ namespace path ::test_ns_1
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_2::getpath] [namespace delete ::test_ns_1] [::test_ns_2::getpath]
+} -result {::test_ns_1 {} {}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ namespace delete ::test_ns_2
+}
+test namespace-51.8 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ }
+ namespace eval ::test_ns_3 {
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [::test_ns_4::getpath]
+} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {::test_ns_1 ::test_ns_3}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.9 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ }
+ namespace eval ::test_ns_2 {
+ }
+ namespace eval ::test_ns_3 {
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_1 ::test_ns_2 ::test_ns_3}
+ proc getpath {} {namespace path}
+ }
+ list [::test_ns_4::getpath] [namespace delete ::test_ns_2] [namespace eval ::test_ns_2 {}] [::test_ns_4::getpath]
+} -result {{::test_ns_1 ::test_ns_2 ::test_ns_3} {} {} {::test_ns_1 ::test_ns_3}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.10 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ namespace path does::not::exist
+ }
+} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup {
+ catch {namespace delete ::test_ns_1}
+}
+test namespace-51.11 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {return 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_3 {
+ namespace path ::test_ns_1
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_3 ::test_ns_2}
+ foo
+ }
+} -result 2 -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.12 {name resolution path control} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {return 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_3 {
+ namespace path ::test_ns_1
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_3 ::test_ns_2}
+ list [foo] [namespace delete ::test_ns_3] [foo]
+ }
+} -result {2 {} 2} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+# Fails right now due to unrelated bug...
+test namespace-51.13 {name resolution path control} -constraints knownBug -body {
+ set ::result {}
+ namespace eval ::test_ns_1 {
+ proc foo {} {lappend ::result 1}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo {} {lappend ::result 2}
+ trace add command foo delete {namespace eval ::test_ns_3 foo;#}
+ }
+ namespace eval ::test_ns_3 {
+ proc foo {} {
+ lappend ::result 3
+ namespace delete [namespace current]
+ ::test_ns_4::bar
+ }
+ }
+ namespace eval ::test_ns_4 {
+ namespace path {::test_ns_2 ::test_ns_3 ::test_ns_1}
+ proc bar {} {
+ list [foo] [namespace delete ::test_ns_2] [foo]
+ }
+ bar
+ }
+ # Should the result be "2 {} {2 3 1 1}" instead?
+} -result {2 {} {2 3 2 1}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+ catch {namespace delete ::test_ns_4}
+}
+test namespace-51.14 {name resolution path control} -body {
+ proc foo0 {} {}
+ namespace eval ::test_ns_1 {
+ proc foo1 {} {}
+ }
+ namespace eval ::test_ns_2 {
+ proc foo2 {} {}
+ }
+ namespace eval ::test_ns_3 {
+ variable result {}
+ lappend result [info commands foo*]
+ namespace path {::test_ns_1 ::test_ns_2}
+ lappend result [info commands foo*]
+ proc foo2 {} {}
+ lappend result [info commands foo*]
+ rename foo2 {}
+ lappend result [info commands foo*]
+ namespace delete ::test_ns_1
+ lappend result [info commands foo*]
+ }
+} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup {
+ catch {namespace delete ::test_ns_1}
+ catch {namespace delete ::test_ns_2}
+ catch {namespace delete ::test_ns_3}
+}
+test namespace-51.15 {namespace resolution path control} -body {
+ namespace eval ::test_ns_2 {
+ proc foo {} {return 2}
+ }
+ namespace eval ::test_ns_1 {
+ namespace eval test_ns_2 {
+ proc foo {} {return 1_2}
+ }
+ namespace eval test_ns_3 {
+ namespace path ::test_ns_1
+ test_ns_2::foo
+ }
+ }
+} -result 1_2 -cleanup {
+ namespace delete ::test_ns_1
+ namespace delete ::test_ns_2
+}
+
# cleanup
catch {rename cmd1 {}}
catch {unset l}
generated by cgit v0.12 at 2024-11-09 16:42:49 (GMT)