summaryrefslogtreecommitdiffstats
path: root/generic/tclNamesp.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2005-05-30 00:04:24 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2005-05-30 00:04:24 (GMT)
commit226baeea03144cecb753db8d1aa9e016d28fac06 (patch)
tree91fac3699c0ef1f44307ec17de71b31609962940 /generic/tclNamesp.c
parente71c1f4ae2af9702d5f0aa3a63f7ef60474ad0be (diff)
downloadtcl-226baeea03144cecb753db8d1aa9e016d28fac06.zip
tcl-226baeea03144cecb753db8d1aa9e016d28fac06.tar.gz
tcl-226baeea03144cecb753db8d1aa9e016d28fac06.tar.bz2
TIP#229 implementation
Diffstat (limited to 'generic/tclNamesp.c')
-rw-r--r--generic/tclNamesp.c374
1 files changed, 348 insertions, 26 deletions
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