Attachment "tclNamesp.c" to
ticket [1437008fff]
added by
dkf
2006-02-23 04:25:51.
/*
* tclNamesp.c --
*
* Contains support for namespaces, which provide a separate context of
* commands and global variables. The global :: namespace is the
* traditional Tcl "global" scope. Other namespaces are created as
* children of the global namespace. These other namespaces contain
* special-purpose commands and variables for packages. Also includes
* the TIP#112 ensemble machinery.
*
* Copyright (c) 1993-1997 Lucent Technologies.
* Copyright (c) 1997 Sun Microsystems, Inc.
* Copyright (c) 1998-1999 by Scriptics Corporation.
* Copyright (c) 2002-2005 Donal K. Fellows.
*
* Originally implemented by
* Michael J. McLennan
* Bell Labs Innovations for Lucent Technologies
* [email protected]
*
* 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.76 2005/05/30 00:04:48 dkf Exp $
*/
#include "tclInt.h"
/*
* Initial size of stack allocated space for tail list - used when resetting
* shadowed command references in the functin: TclResetShadowedCmdRefs.
*/
#define NUM_TRAIL_ELEMS 5
/*
* Thread-local storage used to avoid having a global lock on data
* that is not limited to a single interpreter.
*/
typedef struct ThreadSpecificData {
long numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
* distinguish objects which can be passed
* around between interps in the same thread,
* but does not need to be global because
* object internal reps are always per-thread
* anyway. */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* This structure contains a cached pointer to a namespace that is the
* result of resolving the namespace's name in some other namespace. It is
* the internal representation for a nsName object. It contains the
* pointer along with some information that is used to check the cached
* pointer's validity.
*/
typedef struct ResolvedNsName {
Namespace *nsPtr; /* A cached namespace pointer. */
long nsId; /* nsPtr's unique namespace id. Used to
* verify that nsPtr is still valid
* (e.g., it's possible that the namespace
* was deleted and a new one created at
* the same address). */
Namespace *refNsPtr; /* Points to the namespace containing the
* reference (not the namespace that
* contains the referenced namespace). */
int refCount; /* Reference count: 1 for each nsName
* object that has a pointer to this
* ResolvedNsName structure as its internal
* rep. This structure can be freed when
* refCount becomes zero. */
} ResolvedNsName;
/*
* The client data for an ensemble command. This consists of the
* table of commands that are actually exported by the namespace, and
* an epoch counter that, combined with the exportLookupEpoch field of
* the namespace structure, defines whether the table contains valid
* data or will need to be recomputed next time the ensemble command
* is called.
*/
typedef struct EnsembleConfig {
Namespace *nsPtr; /* The namspace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or
* NULL if the command has been deleted (or
* never existed; the global namespace never
* has an ensemble command.) */
int epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
* number of entries as there are entries in
* the subcommandTable hash. */
Tcl_HashTable subcommandTable;
/* Hash table of ensemble subcommand names,
* which are its keys so this also provides
* the storage management for those subcommand
* names. The contents of the entry values are
* object version the prefix lists to use when
* substituting for the command/subcommand to
* build the ensemble implementation command.
* Has to be stored here as well as in
* subcommandDict because that field is NULL
* when we are deriving the ensemble from the
* namespace exports list.
* FUTURE WORK: use object hash table here. */
struct EnsembleConfig *next;/* The next ensemble in the linked list of
* ensembles associated with a namespace. If
* this field points to this ensemble, the
* structure has already been unlinked from
* all lists, and cannot be found by scanning
* the list from the namespace's ensemble
* field. */
int flags; /* ORed combo of ENS_DEAD and
* TCL_ENSEMBLE_PREFIX. */
/* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
* subcommands to their implementing command
* prefixes, or NULL if we are to build the
* map automatically from the namespace
* exports. */
Tcl_Obj *subcmdList; /* List of commands that this ensemble
* actually provides, and whose implementation
* will be built using the subcommandDict (if
* present and defined) and by simple mapping
* to the namespace otherwise. If NULL,
* indicates that we are using the (dynamic)
* list of currently exported commands. */
Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
* no match is found (according to the rule
* defined by flag bit TCL_ENSEMBLE_PREFIX) or
* NULL to use the default error-generating
* behaviour. The script execution gets all
* the arguments to the ensemble command
* (including objv[0]) and will have the
* results passed directly back to the caller
* (including the error code) unless the code
* is TCL_CONTINUE in which case the subcommand
* will be reparsed by the ensemble core,
* presumably because the ensemble itself has
* been updated. */
} EnsembleConfig;
#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead
* and on its way out. */
/*
* The data cached in a subcommand's Tcl_Obj rep. This structure is
* not shared between Tcl_Objs referring to the same subcommand, even
* where one is a duplicate of another.
*/
typedef struct EnsembleCmdRep {
Namespace *nsPtr; /* The namespace backing the ensemble which
* this is a subcommand of. */
int epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Tcl_Command token; /* Reference to the comamnd for which this
* structure is a cache of the resolution. */
char *fullSubcmdName; /* The full (local) name of the subcommand,
* allocated with ckalloc(). */
Tcl_Obj *realPrefixObj; /* Object containing the prefix words of the
* command that implements this ensemble
* subcommand. */
} EnsembleCmdRep;
/*
* Declarations for procedures local to this file:
*/
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,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static char * ErrorInfoRead _ANSI_ARGS_(( ClientData clientData,
Tcl_Interp *interp, CONST char *name1,
CONST char *name2, int flags));
static char * EstablishErrorCodeTraces _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
CONST char *name1, CONST char *name2, int flags));
static char * EstablishErrorInfoTraces _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
CONST char *name1, CONST char *name2, int flags));
static void FreeNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
static int InvokeImportedCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceChildrenCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceCodeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceCurrentCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceDeleteCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceEnsembleCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceEvalCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceExistsCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceExportCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceForgetCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr));
static int NamespaceImportCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceInscopeCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceOriginCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
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[]));
static int NamespaceTailCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int NamespaceWhichCmd _ANSI_ARGS_((
ClientData dummy, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static int SetNsNameFromAny _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr));
static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
static int NsEnsembleImplementationCmd _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[]));
static void BuildEnsembleConfig _ANSI_ARGS_((
EnsembleConfig *ensemblePtr));
static int NsEnsembleStringOrder _ANSI_ARGS_((CONST VOID *strPtr1,
CONST VOID *strPtr2));
static void DeleteEnsembleConfig _ANSI_ARGS_((
ClientData clientData));
static void MakeCachedEnsembleCommand _ANSI_ARGS_((
Tcl_Obj *objPtr, EnsembleConfig *ensemblePtr,
CONST char *subcmdName, Tcl_Obj *prefixObjPtr));
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
* namespace reference. It is used in commands that take the
* name of a namespace as an argument. The namespace reference
* is resolved, and the result in cached in the object.
*/
Tcl_ObjType tclNsNameType = {
"nsName", /* the type's name */
FreeNsNameInternalRep, /* freeIntRepProc */
DupNsNameInternalRep, /* dupIntRepProc */
UpdateStringOfNsName, /* updateStringProc */
SetNsNameFromAny /* setFromAnyProc */
};
/*
* This structure defines a Tcl object type that contains a reference
* to an ensemble subcommand (e.g. the "length" in [string length ab])
* It is used to cache the mapping between the subcommand itself and
* the real command that implements it.
*/
Tcl_ObjType tclEnsembleCmdType = {
"ensembleCommand", /* the type's name */
FreeEnsembleCmdRep, /* freeIntRepProc */
DupEnsembleCmdRep, /* dupIntRepProc */
StringOfEnsembleCmdRep, /* updateStringProc */
NULL /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* TclInitNamespaceSubsystem --
*
* This procedure is called to initialize all the structures that
* are used by namespaces on a per-process basis.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclInitNamespaceSubsystem()
{
/*
* Does nothing for now.
*/
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetCurrentNamespace --
*
* Returns a pointer to an interpreter's currently active namespace.
*
* Results:
* Returns a pointer to the interpreter's current namespace.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetCurrentNamespace(interp)
register Tcl_Interp *interp; /* Interpreter whose current namespace is
* being queried. */
{
register Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr;
if (iPtr->varFramePtr != NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
} else {
nsPtr = iPtr->globalNsPtr;
}
return (Tcl_Namespace *) nsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetGlobalNamespace --
*
* Returns a pointer to an interpreter's global :: namespace.
*
* Results:
* Returns a pointer to the specified interpreter's global namespace.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_GetGlobalNamespace(interp)
register Tcl_Interp *interp; /* Interpreter whose global namespace
* should be returned. */
{
register Interp *iPtr = (Interp *) interp;
return (Tcl_Namespace *) iPtr->globalNsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PushCallFrame --
*
* Pushes a new call frame onto the interpreter's Tcl call stack.
* Called when executing a Tcl procedure or a "namespace eval" or
* "namespace inscope" command.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result object) if something goes wrong.
*
* Side effects:
* Modifies the interpreter's Tcl call stack.
*
*----------------------------------------------------------------------
*/
int
Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
Tcl_Interp *interp; /* Interpreter in which the new call frame
* is to be pushed. */
Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to
* push. Storage for this has already been
* allocated by the caller; typically this
* is the address of a CallFrame structure
* allocated on the caller's C stack. The
* call frame will be initialized by this
* procedure. The caller can pop the frame
* later with Tcl_PopCallFrame, and it is
* responsible for freeing the frame's
* storage. */
Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
* frame will execute. If NULL, the
* interpreter's current namespace will
* be used. */
int isProcCallFrame; /* If nonzero, the frame represents a
* called Tcl procedure and may have local
* vars. Vars will ordinarily be looked up
* in the frame. If new variables are
* created, they will be created in the
* frame. If 0, the frame is for a
* "namespace eval" or "namespace inscope"
* command and var references are treated
* as references to namespace variables. */
{
Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = (CallFrame *) callFramePtr;
register Namespace *nsPtr;
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
if (nsPtr->flags & NS_DEAD) {
Tcl_Panic("Trying to push call frame for dead namespace");
/*NOTREACHED*/
}
}
nsPtr->activationCount++;
framePtr->nsPtr = nsPtr;
framePtr->isProcCallFrame = isProcCallFrame;
framePtr->objc = 0;
framePtr->objv = NULL;
framePtr->callerPtr = iPtr->framePtr;
framePtr->callerVarPtr = iPtr->varFramePtr;
if (iPtr->varFramePtr != NULL) {
framePtr->level = (iPtr->varFramePtr->level + 1);
} else {
framePtr->level = 1;
}
framePtr->procPtr = NULL; /* no called procedure */
framePtr->varTablePtr = NULL; /* and no local variables */
framePtr->numCompiledLocals = 0;
framePtr->compiledLocals = NULL;
/*
* Push the new call frame onto the interpreter's stack of procedure
* call frames making it the current frame.
*/
iPtr->framePtr = framePtr;
iPtr->varFramePtr = framePtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_PopCallFrame --
*
* Removes a call frame from the Tcl call stack for the interpreter.
* Called to remove a frame previously pushed by Tcl_PushCallFrame.
*
* Results:
* None.
*
* Side effects:
* Modifies the call stack of the interpreter. Resets various fields of
* the popped call frame. If a namespace has been deleted and
* has no more activations on the call stack, the namespace is
* destroyed.
*
*----------------------------------------------------------------------
*/
void
Tcl_PopCallFrame(interp)
Tcl_Interp* interp; /* Interpreter with call frame to pop. */
{
register Interp *iPtr = (Interp *) interp;
register CallFrame *framePtr = iPtr->framePtr;
Namespace *nsPtr;
/*
* It's important to remove the call frame from the interpreter's stack
* of call frames before deleting local variables, so that traces
* invoked by the variable deletion don't see the partially-deleted
* frame.
*/
iPtr->framePtr = framePtr->callerPtr;
iPtr->varFramePtr = framePtr->callerVarPtr;
if (framePtr->varTablePtr != NULL) {
TclDeleteVars(iPtr, framePtr->varTablePtr);
ckfree((char *) framePtr->varTablePtr);
framePtr->varTablePtr = NULL;
}
if (framePtr->numCompiledLocals > 0) {
TclDeleteCompiledLocalVars(iPtr, framePtr);
}
/*
* Decrement the namespace's count of active call frames. If the
* namespace is "dying" and there are no more active call frames,
* call Tcl_DeleteNamespace to destroy it.
*/
nsPtr = framePtr->nsPtr;
nsPtr->activationCount--;
if ((nsPtr->flags & NS_DYING) && (nsPtr->activationCount == 0)) {
Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
}
framePtr->nsPtr = NULL;
}
/*
*----------------------------------------------------------------------
*
* TclPushStackFrame --
*
* Allocates a new call frame in the interpreter's execution stack, then
* pushes it onto the interpreter's Tcl call stack.
* Called when executing a Tcl procedure or a "namespace eval" or
* "namespace inscope" command.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result object) if something goes wrong.
*
* Side effects:
* Modifies the interpreter's Tcl call stack.
*
*----------------------------------------------------------------------
*/
int
TclPushStackFrame(interp, framePtrPtr, namespacePtr, isProcCallFrame)
Tcl_Interp *interp; /* Interpreter in which the new call frame
* is to be pushed. */
Tcl_CallFrame **framePtrPtr; /* Place to store a pointer to the stack
* allocated call frame.*/
Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
* frame will execute. If NULL, the
* interpreter's current namespace will
* be used. */
int isProcCallFrame; /* If nonzero, the frame represents a
* called Tcl procedure and may have local
* vars. Vars will ordinarily be looked up
* in the frame. If new variables are
* created, they will be created in the
* frame. If 0, the frame is for a
* "namespace eval" or "namespace inscope"
* command and var references are treated
* as references to namespace variables. */
{
*framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, isProcCallFrame);
}
void
TclPopStackFrame(interp)
Tcl_Interp* interp; /* Interpreter with call frame to pop. */
{
Tcl_PopCallFrame(interp);
TclStackFree(interp);
}
/*
*----------------------------------------------------------------------
*
* EstablishErrorCodeTraces --
*
* Creates traces on the ::errorCode variable to keep its value
* consistent with the expectations of legacy code.
*
* Results:
* None.
*
* Side effects:
* Read and unset traces are established on ::errorCode.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorCodeTraces(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
ErrorCodeRead, (ClientData) NULL);
Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
EstablishErrorCodeTraces, (ClientData) NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ErrorCodeRead --
*
* Called when the ::errorCode variable is read. Copies the
* current value of the interp's errorCode field into ::errorCode.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorCodeRead(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Interp *iPtr = (Interp *)interp;
if (flags & TCL_INTERP_DESTROYED) return NULL;
if (iPtr->errorCode == NULL) return NULL;
Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* EstablishErrorInfoTraces --
*
* Creates traces on the ::errorInfo variable to keep its value
* consistent with the expectations of legacy code.
*
* Results:
* None.
*
* Side effects:
* Read and unset traces are established on ::errorInfo.
*
*----------------------------------------------------------------------
*/
static char *
EstablishErrorInfoTraces(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
ErrorInfoRead, (ClientData) NULL);
Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
EstablishErrorInfoTraces, (ClientData) NULL);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* ErrorInfoRead --
*
* Called when the ::errorInfo variable is read. Copies the
* current value of the interp's errorInfo field into ::errorInfo.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
ErrorInfoRead(clientData, interp, name1, name2, flags)
ClientData clientData;
Tcl_Interp *interp;
CONST char *name1;
CONST char *name2;
int flags;
{
Interp *iPtr = (Interp *)interp;
if (flags & TCL_INTERP_DESTROYED) return NULL;
if (iPtr->errorInfo == NULL) return NULL;
Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, TCL_GLOBAL_ONLY);
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateNamespace --
*
* Creates a new namespace with the given name. If there is no
* active namespace (i.e., the interpreter is being initialized),
* the global :: namespace is created and returned.
*
* Results:
* Returns a pointer to the new namespace if successful. If the
* namespace already exists or if another error occurs, this routine
* returns NULL, along with an error message in the interpreter's
* result object.
*
* Side effects:
* If the name contains "::" qualifiers and a parent namespace does
* not already exist, it is automatically created.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_CreateNamespace(interp, name, clientData, deleteProc)
Tcl_Interp *interp; /* Interpreter in which a new namespace
* is being created. Also used for
* error reporting. */
CONST char *name; /* Name for the new namespace. May be a
* qualified name with names of ancestor
* namespaces separated by "::"s. */
ClientData clientData; /* One-word value to store with
* namespace. */
Tcl_NamespaceDeleteProc *deleteProc;
/* Procedure called to delete client
* data when the namespace is deleted.
* NULL if no procedure should be
* called. */
{
Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
/*
* If there is no active namespace, the interpreter is being
* initialized.
*/
if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
/*
* Treat this namespace as the global namespace, and avoid
* looking for a parent.
*/
parentPtr = NULL;
simpleName = "";
} else if (*name == '\0') {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't create namespace \"\": ",
"only global namespace can have empty name", NULL);
return NULL;
} else {
/*
* Find the parent for the new namespace.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
/*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
&parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
/*
* If the unqualified name at the end is empty, there were trailing
* "::"s after the namespace's name which we ignore. The new
* namespace was already (recursively) created and is pointed to
* by parentPtr.
*/
if (*simpleName == '\0') {
return (Tcl_Namespace *) parentPtr;
}
/*
* Check for a bad namespace name and make sure that the name
* does not already exist in the parent namespace.
*/
if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
Tcl_AppendResult(interp, "can't create namespace \"", name,
"\": already exists", (char *) NULL);
return NULL;
}
}
/*
* Create the new namespace and root it in its parent. Increment the
* count of namespaces created.
*/
nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
strcpy(nsPtr->name, simpleName);
nsPtr->fullName = NULL; /* set below */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
nsPtr->parentPtr = parentPtr;
Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
nsPtr->nsId = ++(tsdPtr->numNsCreated);
nsPtr->interp = interp;
nsPtr->flags = 0;
nsPtr->activationCount = 0;
nsPtr->refCount = 0;
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
nsPtr->cmdRefEpoch = 0;
nsPtr->resolverEpoch = 0;
nsPtr->cmdResProc = NULL;
nsPtr->varResProc = NULL;
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,
&newEntry);
Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
} else {
/*
* In the global namespace create traces to maintain the
* ::errorInfo and ::errorCode variables.
*/
iPtr->globalNsPtr = nsPtr;
EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
}
/*
* Build the fully qualified name for this namespace.
*/
Tcl_DStringInit(&buffer1);
Tcl_DStringInit(&buffer2);
for (ancestorPtr = nsPtr; ancestorPtr != NULL;
ancestorPtr = ancestorPtr->parentPtr) {
if (ancestorPtr != globalNsPtr) {
Tcl_DStringAppend(&buffer1, "::", 2);
Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1);
}
Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1);
Tcl_DStringSetLength(&buffer2, 0);
Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1);
Tcl_DStringSetLength(&buffer1, 0);
}
name = Tcl_DStringValue(&buffer2);
nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1));
strcpy(nsPtr->fullName, name);
Tcl_DStringFree(&buffer1);
Tcl_DStringFree(&buffer2);
/*
* Return a pointer to the new namespace.
*/
return (Tcl_Namespace *) nsPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_DeleteNamespace --
*
* Deletes a namespace and all of the commands, variables, and other
* namespaces within it.
*
* Results:
* None.
*
* Side effects:
* When a namespace is deleted, it is automatically removed as a
* child of its parent namespace. Also, all its commands, variables
* and child namespaces are deleted.
*
*----------------------------------------------------------------------
*/
void
Tcl_DeleteNamespace(namespacePtr)
Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */
{
register Namespace *nsPtr = (Namespace *) namespacePtr;
Interp *iPtr = (Interp *) nsPtr->interp;
Namespace *globalNsPtr =
(Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
Tcl_HashEntry *entryPtr;
/*
* If the namespace has associated ensemble commands, delete them
* first. This leaves the actual contents of the namespace alone
* (unless they are linked ensemble commands, of course.) Note
* that this code is actually reentrant so command delete traces
* won't purturb things badly.
*/
while (nsPtr->ensembles != NULL) {
/*
* Splice out and link to indicate that we've already been
* killed.
*/
EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
ensemblePtr->next = ensemblePtr;
Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
}
/*
* If the namespace is on the call frame stack, it is marked as "dying"
* (NS_DYING is OR'd into its flags): the namespace can't be looked up
* by name but its commands and variables are still usable by those
* active call frames. When all active call frames referring to the
* namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
* call this procedure again to delete everything in the namespace.
* If no nsName objects refer to the namespace (i.e., if its refCount
* is zero), its commands and variables are deleted and the storage for
* its namespace structure is freed. Otherwise, if its refCount is
* nonzero, the namespace's commands and variables are deleted but the
* structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
* flags to allow the namespace resolution code to recognize that the
* namespace is "deleted". The structure's storage is freed by
* FreeNsNameInternalRep when its refCount reaches 0.
*/
if (nsPtr->activationCount > 0) {
nsPtr->flags |= NS_DYING;
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
nsPtr->parentPtr = NULL;
} else {
/*
* Delete the namespace and everything in it. If this is the global
* namespace, then clear it but don't free its storage unless the
* interpreter is being torn down.
*/
TclTeardownNamespace(nsPtr);
if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
/*
* If this is the global namespace, then it may have residual
* "errorInfo" and "errorCode" variables for errors that
* occurred while it was being torn down. Try to clear the
* variable list one last time.
*/
TclDeleteVars((Interp *) nsPtr->interp, &nsPtr->varTable);
Tcl_DeleteHashTable(&nsPtr->childTable);
Tcl_DeleteHashTable(&nsPtr->cmdTable);
/*
* If the reference count is 0, then discard the namespace.
* Otherwise, mark it as "dead" so that it can't be used.
*/
if (nsPtr->refCount == 0) {
NamespaceFree(nsPtr);
} else {
nsPtr->flags |= NS_DEAD;
}
} else {
/* Restore the ::errorInfo and ::errorCode traces */
EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
}
}
}
/*
*----------------------------------------------------------------------
*
* TclTeardownNamespace --
*
* Used internally to dismantle and unlink a namespace when it is
* deleted. Divorces the namespace from its parent, and deletes all
* commands, variables, and child namespaces.
*
* This is kept separate from Tcl_DeleteNamespace so that the global
* namespace can be handled specially.
*
* Results:
* None.
*
* Side effects:
* Removes this namespace from its parent's child namespace hashtable.
* Deletes all commands, variables and namespaces in this namespace.
*
*----------------------------------------------------------------------
*/
void
TclTeardownNamespace(nsPtr)
register Namespace *nsPtr; /* Points to the namespace to be dismantled
* and unlinked from its parent. */
{
Interp *iPtr = (Interp *) nsPtr->interp;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Namespace *childNsPtr;
Tcl_Command cmd;
int i;
/*
* Start by destroying the namespace's variable table,
* since variables might trigger traces.
* Variable table should be cleared but not freed!
* TclDeleteVars frees it, so we reinitialize it afterwards.
*/
TclDeleteVars(iPtr, &nsPtr->varTable);
Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
/*
* Remove the namespace from its parent's child hashtable.
*/
if (nsPtr->parentPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
nsPtr->name);
if (entryPtr != NULL) {
Tcl_DeleteHashEntry(entryPtr);
}
}
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
* itself from its parent. You can't traverse a hash table
* properly if its elements are being deleted. We use only
* the Tcl_FirstHashEntry function to be safe.
*
* Don't optimize to Tcl_NextHashEntry() because of traces.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
Tcl_DeleteNamespace(childNsPtr);
}
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
* command table.
*
* Don't optimize to Tcl_NextHashEntry() because of traces.
*/
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
}
Tcl_DeleteHashTable(&nsPtr->cmdTable);
Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
/*
* Free the namespace's export pattern array.
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
/*
* Free any client data associated with the namespace.
*/
if (nsPtr->deleteProc != NULL) {
(*nsPtr->deleteProc)(nsPtr->clientData);
}
nsPtr->deleteProc = NULL;
nsPtr->clientData = NULL;
/*
* Reset the namespace's id field to ensure that this namespace won't
* be interpreted as valid by, e.g., the cache validation code for
* cached command references in Tcl_GetCommandFromObj.
*/
nsPtr->nsId = 0;
}
/*
*----------------------------------------------------------------------
*
* NamespaceFree --
*
* Called after a namespace has been deleted, when its
* reference count reaches 0. Frees the data structure
* representing the namespace.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
NamespaceFree(nsPtr)
register Namespace *nsPtr; /* Points to the namespace to free. */
{
/*
* Most of the namespace's contents are freed when the namespace is
* deleted by Tcl_DeleteNamespace. All that remains is to free its names
* (for error messages), and the structure itself.
*/
ckfree(nsPtr->name);
ckfree(nsPtr->fullName);
ckfree((char *) nsPtr);
}
/*
*----------------------------------------------------------------------
*
* Tcl_Export --
*
* Makes all the commands matching a pattern available to later be
* imported from the namespace specified by namespacePtr (or the
* current namespace if namespacePtr is NULL). The specified pattern is
* appended onto the namespace's export pattern list, which is
* optionally cleared beforehand.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result) if something goes wrong.
*
* Side effects:
* Appends the export pattern onto the namespace's export list.
* Optionally reset the namespace's export pattern list.
*
*----------------------------------------------------------------------
*/
int
Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* commands are to be exported. NULL for
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to export. This pattern may not include
* any namespace qualifiers; only commands
* in the specified namespace may be
* exported. */
int resetListFirst; /* If nonzero, resets the namespace's
* export list before appending. */
{
#define INIT_EXPORT_PATTERNS 5
Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
CONST char *simplePattern;
char *patternCpy;
int neededElems, len, i;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) currNsPtr;
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* If resetListFirst is true (nonzero), clear the namespace's export
* pattern list.
*/
if (resetListFirst) {
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
ckfree(nsPtr->exportArrayPtr[i]);
}
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = NULL;
TclInvalidateNsCmdLookup(nsPtr);
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = 0;
}
}
/*
* Check that the pattern doesn't have namespace qualifiers.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
"\": pattern can't specify a namespace", (char *) NULL);
return TCL_ERROR;
}
/*
* Make sure that we don't already have the pattern in the array
*/
if (nsPtr->exportArrayPtr != NULL) {
for (i = 0; i < nsPtr->numExportPatterns; i++) {
if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
/*
* The pattern already exists in the list
*/
return TCL_OK;
}
}
}
/*
* Make sure there is room in the namespace's pattern array for the
* new pattern.
*/
neededElems = nsPtr->numExportPatterns + 1;
if (nsPtr->exportArrayPtr == NULL) {
nsPtr->exportArrayPtr = (char **)
ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
nsPtr->numExportPatterns = 0;
nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
} else if (neededElems > nsPtr->maxExportPatterns) {
int numNewElems = 2 * nsPtr->maxExportPatterns;
size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
size_t newBytes = numNewElems * sizeof(char *);
char **newPtr = (char **) ckalloc((unsigned) newBytes);
memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, currBytes);
ckfree((char *) nsPtr->exportArrayPtr);
nsPtr->exportArrayPtr = (char **) newPtr;
nsPtr->maxExportPatterns = numNewElems;
}
/*
* Add the pattern to the namespace's array of export patterns.
*/
len = strlen(pattern);
patternCpy = (char *) ckalloc((unsigned) (len + 1));
strcpy(patternCpy, pattern);
nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
nsPtr->numExportPatterns++;
/*
* The list of commands actually exported from the namespace might
* have changed (probably will have!) However, we do not need to
* recompute this just yet; next time we need the info will be
* soon enough.
*/
TclInvalidateNsCmdLookup(nsPtr);
return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
/*
*----------------------------------------------------------------------
*
* Tcl_AppendExportList --
*
* Appends onto the argument object the list of export patterns for the
* specified namespace.
*
* Results:
* The return value is normally TCL_OK; in this case the object
* referenced by objPtr has each export pattern appended to it. If an
* error occurs, TCL_ERROR is returned and the interpreter's result
* holds an error message.
*
* Side effects:
* If necessary, the object referenced by objPtr is converted into
* a list object.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppendExportList(interp, namespacePtr, objPtr)
Tcl_Interp *interp; /* Interpreter used for error reporting. */
Tcl_Namespace *namespacePtr; /* Points to the namespace whose export
* pattern list is appended onto objPtr.
* NULL for the current namespace. */
Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
* export pattern list is appended. */
{
Namespace *nsPtr;
int i, result;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* Append the export pattern list onto objPtr.
*/
for (i = 0; i < nsPtr->numExportPatterns; i++) {
result = Tcl_ListObjAppendElement(interp, objPtr,
Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_Import --
*
* Imports all of the commands matching a pattern into the namespace
* specified by namespacePtr (or the current namespace if contextNsPtr
* is NULL). This is done by creating a new command (the "imported
* command") that points to the real command in its original namespace.
*
* If matching commands are on the autoload path but haven't been
* loaded yet, this command forces them to be loaded, then creates
* the links to them.
*
* Results:
* Returns TCL_OK if successful, or TCL_ERROR (along with an error
* message in the interpreter's result) if something goes wrong.
*
* Side effects:
* Creates new commands in the importing namespace. These indirect
* calls back to the real command and are deleted if the real commands
* are deleted.
*
*----------------------------------------------------------------------
*/
int
Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace into which the
* commands are to be imported. NULL for
* the current namespace. */
CONST char *pattern; /* String pattern indicating which commands
* to import. This pattern should be
* qualified by the name of the namespace
* from which to import the command(s). */
int allowOverwrite; /* If nonzero, allow existing commands to
* be overwritten by imported commands.
* If 0, return an error if an imported
* cmd conflicts with an existing one. */
{
Namespace *nsPtr, *importNsPtr, *dummyPtr;
CONST char *simplePattern;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* First, invoke the "auto_import" command with the pattern
* being imported. This command is part of the Tcl library.
* It looks for imported commands in autoloaded libraries and
* loads them in. That way, they will be found when we try
* to create links below.
*
* Note that we don't just call Tcl_EvalObjv() directly because we
* do not want absence of the command to be a failure case.
*/
if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
Tcl_Obj *objv[2];
int result;
objv[0] = Tcl_NewStringObj("auto_import", -1);
objv[1] = Tcl_NewStringObj(pattern, -1);
Tcl_IncrRefCount(objv[0]);
Tcl_IncrRefCount(objv[1]);
result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(objv[0]);
Tcl_DecrRefCount(objv[1]);
if (result != TCL_OK) {
return TCL_ERROR;
}
Tcl_ResetResult(interp);
}
/*
* From the pattern, find the namespace from which we are importing
* and get the simple pattern (no namespace qualifiers or ::'s) at
* the end.
*/
if (strlen(pattern) == 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
return TCL_ERROR;
}
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (importNsPtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace in import pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
if (importNsPtr == nsPtr) {
if (pattern == simplePattern) {
Tcl_AppendResult(interp,
"no namespace specified in import pattern \"", pattern,
"\"", (char *) NULL);
} else {
Tcl_AppendResult(interp, "import pattern \"", pattern,
"\" tries to import from namespace \"",
importNsPtr->name, "\" into itself", (char *) NULL);
}
return TCL_ERROR;
}
/*
* Scan through the command table in the source namespace and look for
* exported commands that match the string pattern. Create an "imported
* command" in the current namespace for each imported command; these
* 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)
&& (TCL_ERROR == DoImport( interp, nsPtr, hPtr, cmdName,
pattern, importNsPtr, allowOverwrite))) {
return TCL_ERROR;
}
}
return TCL_OK;
}
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;
/*
* The command cmdName in the source namespace matches the
* pattern. Check whether it was exported. If it wasn't,
* we ignore it.
*/
while (!exported && (i < importNsPtr->numExportPatterns)) {
exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
}
if (!exported) {
return TCL_OK;
}
/*
* Unless there is a name clash, create an imported command
* in the current namespace that refers to cmdPtr.
*/
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.
*/
Tcl_DString ds;
Tcl_Command importedCmd;
ImportedCmdData *dataPtr = (ImportedCmdData *) NULL;
Command *cmdPtr = (Command *) NULL,
*importedCmdPtr = (Command *) NULL;
ImportRef *refPtr = (ImportRef *) NULL;
Tcl_DStringInit(&ds);
Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
if (nsPtr != ((Interp *) interp)->globalNsPtr) {
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
* command references.
*/
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;
}
}
}
dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
importedCmd = Tcl_CreateObjCommand(interp,
Tcl_DStringValue(&ds), InvokeImportedCmd,
(ClientData) dataPtr, DeleteImportedCmd);
importedCmdPtr = (Command *) importedCmd;
importedCmdPtr->flags |= CMD_IS_IMPORTED;
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;
}
/*
*----------------------------------------------------------------------
*
* Tcl_ForgetImport --
*
* Deletes commands previously imported into the namespace indicated. The
* by namespacePtr, or the current namespace of interp, when
* namespacePtr is NULL. The pattern controls which imported commands
* are deleted. A simple pattern, one without namespace separators,
* matches the current command names of imported commands in the
* namespace. Matching imported commands are deleted. A qualified
* pattern is interpreted as deletion selection on the basis of where
* the command is imported from. The original command and "first link"
* command for each imported command are determined, and they are matched
* against the pattern. A match leads to deletion of the imported
* command.
*
* Results:
* Returns TCL_ERROR and records an error message in the interp
* result if a namespace qualified pattern refers to a namespace
* that does not exist. Otherwise, returns TCL_OK.
*
* Side effects:
* May delete commands.
*
*----------------------------------------------------------------------
*/
int
Tcl_ForgetImport(interp, namespacePtr, pattern)
Tcl_Interp *interp; /* Current interpreter. */
Tcl_Namespace *namespacePtr; /* Points to the namespace from which
* previously imported commands should be
* removed. NULL for current namespace. */
CONST char *pattern; /* String pattern indicating which imported
* commands to remove. */
{
Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
CONST char *simplePattern;
char *cmdName;
register Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
/*
* If the specified namespace is NULL, use the current namespace.
*/
if (namespacePtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else {
nsPtr = (Namespace *) namespacePtr;
}
/*
* Parse the pattern into its namespace-qualification (if any)
* and the simple pattern.
*/
TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
&sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
if (sourceNsPtr == NULL) {
Tcl_AppendResult(interp,
"unknown namespace in namespace forget pattern \"",
pattern, "\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(pattern, simplePattern) == 0) {
/*
* The pattern is simple.
* Delete any imported commands that match it.
*/
if (TclMatchIsTrivial(simplePattern)) {
Command *cmdPtr;
hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
if ((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)) {
Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
if (cmdPtr->deleteProc != DeleteImportedCmd) {
continue;
}
cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
if (Tcl_StringMatch(cmdName, simplePattern)) {
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
}
}
return TCL_OK;
}
/* The pattern was namespace-qualified */
for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
hPtr = Tcl_NextHashEntry(&search)) {
Tcl_CmdInfo info;
Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
Tcl_Command origin = TclGetOriginalCommand(token);
if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
continue; /* Not an imported command */
}
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
/*
* Original not in namespace we're matching.
* Check the first link in the import chain.
*/
Command *cmdPtr = (Command *) token;
ImportedCmdData *dataPtr =
(ImportedCmdData *) cmdPtr->objClientData;
Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
if (firstToken == origin) {
continue;
}
Tcl_GetCommandInfoFromToken(firstToken, &info);
if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
continue;
}
origin = firstToken;
}
if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
Tcl_DeleteCommandFromToken(interp, token);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* TclGetOriginalCommand --
*
* An imported command is created in an namespace when a "real" command
* is imported from another namespace. If the specified command is an
* imported command, this procedure returns the original command it
* refers to.
*
* Results:
* If the command was imported into a sequence of namespaces a, b,...,n
* where each successive namespace just imports the command from the
* previous namespace, this procedure returns the Tcl_Command token in
* the first namespace, a. Otherwise, if the specified command is not
* an imported command, the procedure returns NULL.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Command
TclGetOriginalCommand(command)
Tcl_Command command; /* The imported command for which the
* original command should be returned. */
{
register Command *cmdPtr = (Command *) command;
ImportedCmdData *dataPtr;
if (cmdPtr->deleteProc != DeleteImportedCmd) {
return (Tcl_Command) NULL;
}
while (cmdPtr->deleteProc == DeleteImportedCmd) {
dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
cmdPtr = dataPtr->realCmdPtr;
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* InvokeImportedCmd --
*
* Invoked by Tcl whenever the user calls an imported command that
* was created by Tcl_Import. Finds the "real" command (in another
* namespace), and passes control to it.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result object is set to an error message.
*
*----------------------------------------------------------------------
*/
static int
InvokeImportedCmd(clientData, interp, objc, objv)
ClientData clientData; /* Points to the imported command's
* ImportedCmdData structure. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* The argument objects. */
{
register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
register Command *realCmdPtr = dataPtr->realCmdPtr;
return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
objc, objv);
}
/*
*----------------------------------------------------------------------
*
* DeleteImportedCmd --
*
* Invoked by Tcl whenever an imported command is deleted. The "real"
* command keeps a list of all the imported commands that refer to it,
* so those imported commands can be deleted when the real command is
* deleted. This procedure removes the imported command reference from
* the real command's list, and frees up the memory associated with
* the imported command.
*
* Results:
* None.
*
* Side effects:
* Removes the imported command from the real command's import list.
*
*----------------------------------------------------------------------
*/
static void
DeleteImportedCmd(clientData)
ClientData clientData; /* Points to the imported command's
* ImportedCmdData structure. */
{
ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
Command *realCmdPtr = dataPtr->realCmdPtr;
Command *selfPtr = dataPtr->selfPtr;
register ImportRef *refPtr, *prevPtr;
prevPtr = NULL;
for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
refPtr = refPtr->nextPtr) {
if (refPtr->importedCmdPtr == selfPtr) {
/*
* Remove *refPtr from real command's list of imported commands
* that refer to it.
*/
if (prevPtr == NULL) { /* refPtr is first in list */
realCmdPtr->importRefPtr = refPtr->nextPtr;
} else {
prevPtr->nextPtr = refPtr->nextPtr;
}
ckfree((char *) refPtr);
ckfree((char *) dataPtr);
return;
}
prevPtr = refPtr;
}
Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
}
/*
*----------------------------------------------------------------------
*
* TclGetNamespaceForQualName --
*
* Given a qualified name specifying a command, variable, or namespace,
* and a namespace in which to resolve the name, this procedure returns
* a pointer to the namespace that contains the item. A qualified name
* consists of the "simple" name of an item qualified by the names of
* an arbitrary number of containing namespace separated by "::"s. If
* the qualified name starts with "::", it is interpreted absolutely
* from the global namespace. Otherwise, it is interpreted relative to
* the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
* is NULL, the name is interpreted relative to the current namespace.
*
* A relative name like "foo::bar::x" can be found starting in either
* the current namespace or in the global namespace. So each search
* usually follows two tracks, and two possible namespaces are
* returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
* NULL, then that path failed.
*
* If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
* sought only in the global :: namespace. The alternate search
* (also) starting from the global namespace is ignored and
* *altNsPtrPtr is set NULL.
*
* If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
* name is sought only in the namespace specified by cxtNsPtr. The
* alternate search starting from the global namespace is ignored and
* *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
* TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
* the search starts from the namespace specified by cxtNsPtr.
*
* If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace
* components of the qualified name that cannot be found are
* automatically created within their specified parent. This makes sure
* that functions like Tcl_CreateCommand always succeed. There is no
* alternate search path, so *altNsPtrPtr is set NULL.
*
* If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as a
* reference to a namespace, and the entire qualified name is
* followed. If the name is relative, the namespace is looked up only
* in the current namespace. A pointer to the namespace is stored in
* *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if
* TCL_FIND_ONLY_NS is not specified, only the leading components are
* treated as namespace names, and a pointer to the simple name of the
* 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 (TCL_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.
*
* For backwards compatibility with the TclPro byte code loader,
* this function always returns TCL_OK.
*
* Side effects:
* If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
* created.
*
*----------------------------------------------------------------------
*/
int
TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
Tcl_Interp *interp; /* Interpreter in which to find the
* namespace containing qualName. */
CONST char *qualName; /* A namespace-qualified name of an
* command, variable, or namespace. */
Namespace *cxtNsPtr; /* The namespace in which to start the
* search for qualName's namespace. If NULL
* start from the current namespace.
* Ignored if TCL_GLOBAL_ONLY is set. */
int flags; /* Flags controlling the search: an OR'd
* combination of TCL_GLOBAL_ONLY,
* TCL_NAMESPACE_ONLY,
* TCL_CREATE_NS_IF_UNKNOWN, and
* TCL_FIND_ONLY_NS. */
Namespace **nsPtrPtr; /* Address where procedure stores a pointer
* to containing namespace if qualName is
* found starting from *cxtNsPtr or, if
* TCL_GLOBAL_ONLY is set, if qualName is
* found in the global :: namespace. NULL
* is stored otherwise. */
Namespace **altNsPtrPtr; /* Address where procedure stores a pointer
* to containing namespace if qualName is
* found starting from the global ::
* namespace. NULL is stored if qualName
* isn't found starting from :: or if the
* TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
* TCL_CREATE_NS_IF_UNKNOWN, TCL_FIND_ONLY_NS
* flag is set. */
Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer
* to the actual namespace from which the
* search started. This is either cxtNsPtr,
* the :: namespace if TCL_GLOBAL_ONLY was
* specified, or the current namespace if
* cxtNsPtr was NULL. */
CONST char **simpleNamePtr; /* Address where procedure stores the
* simple name at end of the qualName, or
* NULL if qualName is "::" or the flag
* TCL_FIND_ONLY_NS was specified. */
{
Interp *iPtr = (Interp *) interp;
Namespace *nsPtr = cxtNsPtr;
Namespace *altNsPtr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
CONST char *start, *end;
CONST char *nsName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer;
int len;
/*
* Determine the context namespace nsPtr in which to start the primary
* search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
* was specified, search from the global namespace. Otherwise, use the
* namespace given in cxtNsPtr, or if that is NULL, use the current
* namespace context. Note that we always treat two or more
* adjacent ":"s as a namespace separator.
*/
if (flags & TCL_GLOBAL_ONLY) {
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
if (iPtr->varFramePtr != NULL) {
nsPtr = iPtr->varFramePtr->nsPtr;
} else {
nsPtr = iPtr->globalNsPtr;
}
}
start = qualName; /* pts to start of qualifying namespace */
if ((*qualName == ':') && (*(qualName+1) == ':')) {
start = qualName+2; /* skip over the initial :: */
while (*start == ':') {
start++; /* skip over a subsequent : */
}
nsPtr = globalNsPtr;
if (*start == '\0') { /* qualName is just two or more ":"s */
*nsPtrPtr = globalNsPtr;
*altNsPtrPtr = NULL;
*actualCxtPtrPtr = globalNsPtr;
*simpleNamePtr = start; /* points to empty string */
return TCL_OK;
}
}
*actualCxtPtrPtr = nsPtr;
/*
* Start an alternate search path starting with the global namespace.
* However, if the starting context is the global namespace, or if the
* flag is set to search only the namespace *cxtNsPtr, ignore the
* alternate search path.
*/
altNsPtr = globalNsPtr;
if ((nsPtr == globalNsPtr)
|| (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) {
altNsPtr = NULL;
}
/*
* Loop to resolve each namespace qualifier in qualName.
*/
Tcl_DStringInit(&buffer);
end = start;
while (*start != '\0') {
/*
* Find the next namespace qualifier (i.e., a name ending in "::")
* or the end of the qualified name (i.e., a name ending in "\0").
* Set len to the number of characters, starting from start,
* in the name; set end to point after the "::"s or at the "\0".
*/
len = 0;
for (end = start; *end != '\0'; end++) {
if ((*end == ':') && (*(end+1) == ':')) {
end += 2; /* skip over the initial :: */
while (*end == ':') {
end++; /* skip over the subsequent : */
}
break; /* exit for loop; end is after ::'s */
}
len++;
}
if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
/*
* qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
* was specified, look this up as a namespace. Otherwise,
* start is the name of a cmd or var and we are done.
*/
if (flags & TCL_FIND_ONLY_NS) {
nsName = start;
} else {
*nsPtrPtr = nsPtr;
*altNsPtrPtr = altNsPtr;
*simpleNamePtr = start;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
} else {
/*
* start points to the beginning of a namespace qualifier ending
* in "::". end points to the start of a name in that namespace
* that might be empty. Copy the namespace qualifier to a
* buffer so it can be null terminated. We can't modify the
* incoming qualName since it may be a string constant.
*/
Tcl_DStringSetLength(&buffer, 0);
Tcl_DStringAppend(&buffer, start, len);
nsName = Tcl_DStringValue(&buffer);
}
/*
* Look up the namespace qualifier nsName in the current namespace
* context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
* create that qualifying namespace. This is needed for procedures
* like Tcl_CreateCommand that cannot fail.
*/
if (nsPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
if (entryPtr != NULL) {
nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
Tcl_CallFrame *framePtr;
(void) TclPushStackFrame(interp, &framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
(ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
TclPopStackFrame(interp);
if (nsPtr == NULL) {
Tcl_Panic("Could not create namespace '%s'", nsName);
}
} else { /* namespace not found and wasn't created */
nsPtr = NULL;
}
}
/*
* Look up the namespace qualifier in the alternate search path too.
*/
if (altNsPtr != NULL) {
entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
if (entryPtr != NULL) {
altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
} else {
altNsPtr = NULL;
}
}
/*
* If both search paths have failed, return NULL results.
*/
if ((nsPtr == NULL) && (altNsPtr == NULL)) {
*nsPtrPtr = NULL;
*altNsPtrPtr = NULL;
*simpleNamePtr = NULL;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
start = end;
}
/*
* We ignore trailing "::"s in a namespace name, but in a command or
* variable name, trailing "::"s refer to the cmd or var named {}.
*/
if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
*simpleNamePtr = NULL; /* found namespace name */
} else {
*simpleNamePtr = end; /* found cmd/var: points to empty string */
}
/*
* As a special case, if we are looking for a namespace and qualName
* is "" and the current active namespace (nsPtr) is not the global
* namespace, return NULL (no namespace was found). This is because
* namespaces can not have empty names except for the global namespace.
*/
if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
&& (nsPtr != globalNsPtr)) {
nsPtr = NULL;
}
*nsPtrPtr = nsPtr;
*altNsPtrPtr = altNsPtr;
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindNamespace --
*
* Searches for a namespace.
*
* Results:
* Returns a pointer to the namespace if it is found. Otherwise,
* returns NULL and leaves an error message in the interpreter's
* result object if "flags" contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Namespace *
Tcl_FindNamespace(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* namespace. */
CONST char *name; /* Namespace name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set
* or if the name starts with "::".
* Otherwise, points to namespace in which
* to resolve name; if NULL, look up name
* in the current namespace. */
register int flags; /* Flags controlling namespace lookup: an
* OR'd combination of TCL_GLOBAL_ONLY and
* TCL_LEAVE_ERR_MSG flags. */
{
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
CONST char *dummy;
/*
* Find the namespace(s) that contain the specified namespace name.
* Add the TCL_FIND_ONLY_NS flag to resolve the name all the way down
* to its last component, a namespace.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
if (nsPtr != NULL) {
return (Tcl_Namespace *) nsPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown namespace \"", name,
"\"", (char *) NULL);
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindCommand --
*
* Searches for a command.
*
* Results:
* Returns a token for the command if it is found. Otherwise, if it
* can't be found or there is an error, returns NULL and leaves an
* error message in the interpreter's result object if "flags"
* contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_FindCommand(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* command and to report errors. */
CONST char *name; /* Command's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
* Otherwise, points to namespace in which
* to resolve name. If NULL, look up name
* in the current namespace. */
int flags; /* An OR'd combination of flags:
* TCL_GLOBAL_ONLY (look up name only in
* global namespace), TCL_NAMESPACE_ONLY
* (look up only in contextNsPtr, or the
* current namespace if contextNsPtr is
* NULL), and TCL_LEAVE_ERR_MSG. If both
* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
* are given, TCL_GLOBAL_ONLY is
* ignored. */
{
Interp *iPtr = (Interp*)interp;
Namespace *cxtNsPtr;
register Tcl_HashEntry *entryPtr;
register Command *cmdPtr;
CONST char *simpleName;
int result;
/*
* If this namespace has a command resolver, then give it first
* crack at the command resolution. If the interpreter has any
* command resolvers, consult them next. The command resolver
* procedures may return a Tcl_Command value, they may signal
* to continue onward, or they may signal an error.
*/
if (flags & TCL_GLOBAL_ONLY) {
cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
} else if (contextNsPtr != NULL) {
cxtNsPtr = (Namespace *) contextNsPtr;
} else {
cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
ResolverScheme *resPtr = iPtr->resolverPtr;
Tcl_Command cmd;
if (cxtNsPtr->cmdResProc) {
result = (*cxtNsPtr->cmdResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->cmdResProc) {
result = (*resPtr->cmdResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &cmd);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
return cmd;
} else if (result != TCL_CONTINUE) {
return (Tcl_Command) NULL;
}
}
/*
* Find the namespace(s) that contain the command.
*/
cmdPtr = NULL;
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;
}
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown command \"", name,
"\"", (char *) NULL);
}
return (Tcl_Command) NULL;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindNamespaceVar --
*
* Searches for a namespace variable, a variable not local to a
* procedure. The variable can be either a scalar or an array, but
* may not be an element of an array.
*
* Results:
* Returns a token for the variable if it is found. Otherwise, if it
* can't be found or there is an error, returns NULL and leaves an
* error message in the interpreter's result object if "flags"
* contains TCL_LEAVE_ERR_MSG.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
Tcl_Var
Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
Tcl_Interp *interp; /* The interpreter in which to find the
* variable. */
CONST char *name; /* Variable's name. If it starts with "::",
* will be looked up in global namespace.
* Else, looked up first in contextNsPtr
* (current namespace if contextNsPtr is
* NULL), then in global namespace. */
Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
* Otherwise, points to namespace in which
* to resolve name. If NULL, look up name
* in the current namespace. */
int flags; /* An OR'd combination of flags:
* TCL_GLOBAL_ONLY (look up name only in
* global namespace), TCL_NAMESPACE_ONLY
* (look up only in contextNsPtr, or the
* current namespace if contextNsPtr is
* NULL), and TCL_LEAVE_ERR_MSG. If both
* TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
* are given, TCL_GLOBAL_ONLY is
* ignored. */
{
Interp *iPtr = (Interp*)interp;
ResolverScheme *resPtr;
Namespace *nsPtr[2], *cxtNsPtr;
CONST char *simpleName;
Tcl_HashEntry *entryPtr;
Var *varPtr;
register int search;
int result;
Tcl_Var var;
/*
* If this namespace has a variable resolver, then give it first
* crack at the variable resolution. It may return a Tcl_Var
* value, it may signal to continue onward, or it may signal
* an error.
*/
if ((flags & TCL_GLOBAL_ONLY) != 0) {
cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
} else if (contextNsPtr != NULL) {
cxtNsPtr = (Namespace *) contextNsPtr;
} else {
cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
resPtr = iPtr->resolverPtr;
if (cxtNsPtr->varResProc) {
result = (*cxtNsPtr->varResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
} else {
result = TCL_CONTINUE;
}
while (result == TCL_CONTINUE && resPtr) {
if (resPtr->varResProc) {
result = (*resPtr->varResProc)(interp, name,
(Tcl_Namespace *) cxtNsPtr, flags, &var);
}
resPtr = resPtr->nextPtr;
}
if (result == TCL_OK) {
return var;
} else if (result != TCL_CONTINUE) {
return (Tcl_Var) NULL;
}
}
/*
* Find the namespace(s) that contain the variable.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
/*
* Look for the variable in the variable table of its namespace.
* Be sure to check both possible search paths: from the specified
* namespace context and from the global namespace.
*/
varPtr = NULL;
for (search = 0; (search < 2) && (varPtr == NULL); search++) {
if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, simpleName);
if (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
}
}
}
if (varPtr != NULL) {
return (Tcl_Var) varPtr;
} else if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "unknown variable \"", name,
"\"", (char *) NULL);
}
return (Tcl_Var) NULL;
}
/*
*----------------------------------------------------------------------
*
* TclResetShadowedCmdRefs --
*
* Called when a command is added to a namespace to check for existing
* command references that the new command may invalidate. Consider the
* following cases that could happen when you add a command "foo" to a
* namespace "b":
* 1. It could shadow a command named "foo" at the global scope.
* If it does, all command references in the namespace "b" are
* suspect.
* 2. Suppose the namespace "b" resides in a namespace "a".
* Then to "a" the new command "b::foo" could shadow another
* command "b::foo" in the global namespace. If so, then all
* command references in "a" are suspect.
* The same checks are applied to all parent namespaces, until we
* reach the global :: namespace.
*
* Results:
* None.
*
* Side effects:
* If the new command shadows an existing command, the cmdRefEpoch
* counter is incremented in each namespace that sees the shadow.
* This invalidates all command references that were previously cached
* in that namespace. The next time the commands are used, they are
* resolved from scratch.
*
*----------------------------------------------------------------------
*/
void
TclResetShadowedCmdRefs(interp, newCmdPtr)
Tcl_Interp *interp; /* Interpreter containing the new command. */
Command *newCmdPtr; /* Points to the new command. */
{
char *cmdName;
Tcl_HashEntry *hPtr;
register Namespace *nsPtr;
Namespace *trailNsPtr, *shadowNsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
int found, i;
/*
* This procedure generates an array used to hold the trail list. This
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
Namespace **trailPtr = trailStorage;
int trailFront = -1;
int trailSize = NUM_TRAIL_ELEMS;
/*
* Start at the namespace containing the new command, and work up
* through the list of parents. Stop just before the global namespace,
* since the global namespace can't "shadow" its own entries.
*
* The namespace "trail" list we build consists of the names of each
* namespace that encloses the new command, in order from outermost to
* innermost: for example, "a" then "b". Each iteration of this loop
* eventually extends the trail upwards by one namespace, nsPtr. We use
* this trail list to see if nsPtr (e.g. "a" in 2. above) could have
* now-invalid cached command references. This will happen if nsPtr
* (e.g. "a") contains a sequence of child namespaces (e.g. "b")
* such that there is a identically-named sequence of child namespaces
* starting from :: (e.g. "::b") whose tail namespace contains a command
* also named cmdName.
*/
cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
for (nsPtr = newCmdPtr->nsPtr;
(nsPtr != NULL) && (nsPtr != globalNsPtr);
nsPtr = nsPtr->parentPtr) {
/*
* Find the maximal sequence of child namespaces contained in nsPtr
* such that there is a identically-named sequence of child
* namespaces starting from ::. shadowNsPtr will be the tail of this
* sequence, or the deepest namespace under :: that might contain a
* command now shadowed by cmdName. We check below if shadowNsPtr
* actually contains a command cmdName.
*/
found = 1;
shadowNsPtr = globalNsPtr;
for (i = trailFront; i >= 0; i--) {
trailNsPtr = trailPtr[i];
hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
trailNsPtr->name);
if (hPtr != NULL) {
shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
} else {
found = 0;
break;
}
}
/*
* If shadowNsPtr contains a command named cmdName, we invalidate
* all of the command refs cached in nsPtr. As a boundary case,
* shadowNsPtr is initially :: and we check for case 1. above.
*/
if (found) {
hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
if (hPtr != NULL) {
nsPtr->cmdRefEpoch++;
TclInvalidateNsPath(nsPtr);
/*
* If the shadowed command was compiled to bytecodes, we
* invalidate all the bytecodes in nsPtr, to force a new
* compilation. We use the resolverEpoch to signal the need
* for a fresh compilation of every bytecode.
*/
if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
nsPtr->resolverEpoch++;
}
}
}
/*
* Insert nsPtr at the front of the trail list: i.e., at the end
* of the trailPtr array.
*/
trailFront++;
if (trailFront == trailSize) {
size_t currBytes = trailSize * sizeof(Namespace *);
int newSize = 2*trailSize;
size_t newBytes = newSize * sizeof(Namespace *);
Namespace **newPtr =
(Namespace **) ckalloc((unsigned) newBytes);
memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
if (trailPtr != trailStorage) {
ckfree((char *) trailPtr);
}
trailPtr = newPtr;
trailSize = newSize;
}
trailPtr[trailFront] = nsPtr;
}
/*
* Free any allocated storage.
*/
if (trailPtr != trailStorage) {
ckfree((char *) trailPtr);
}
}
/*
*----------------------------------------------------------------------
*
* TclGetNamespaceFromObj --
*
* Gets the namespace specified by the name in a Tcl_Obj.
*
* Results:
* Returns TCL_OK if the namespace was resolved successfully, and
* stores a pointer to the namespace in the location specified by
* nsPtrPtr. If the namespace can't be found, the procedure stores
* NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong,
* this procedure returns TCL_ERROR.
*
* Side effects:
* May update the internal representation for the object, caching the
* namespace reference. The next time this procedure is called, the
* namespace value can be found quickly.
*
* If anything goes wrong, an error message is left in the
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
int
TclGetNamespaceFromObj(interp, objPtr, nsPtrPtr)
Tcl_Interp *interp; /* The current interpreter. */
Tcl_Obj *objPtr; /* The object to be resolved as the name
* of a namespace. */
Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedNsName *resNamePtr;
register Namespace *nsPtr;
Namespace *currNsPtr;
CallFrame *savedFramePtr;
int result = TCL_OK;
char *name;
/*
* If the namespace name is fully qualified, do as if the lookup were
* done from the global namespace; this helps avoid repeated lookups
* of fully qualified names.
*/
savedFramePtr = iPtr->varFramePtr;
name = TclGetString(objPtr);
if ((*name++ == ':') && (*name == ':')) {
iPtr->varFramePtr = NULL;
}
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
/*
* Get the internal representation, converting to a namespace type if
* needed. The internal representation is a ResolvedNsName that points
* to the actual namespace.
*/
if (objPtr->typePtr != &tclNsNameType) {
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
goto done;
}
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
/*
* Check the context namespace of the resolved symbol to make sure that
* it is fresh. If not, then force another conversion to the namespace
* type, to discard the old rep and create a new one. Note that we
* verify that the namespace id of the cached namespace is the same as
* the id when we cached it; this insures that the namespace wasn't
* deleted and a new one created at the same address.
*/
nsPtr = NULL;
if ((resNamePtr != NULL)
&& (resNamePtr->refNsPtr == currNsPtr)
&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
}
if (nsPtr == NULL) { /* try again */
result = tclNsNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
goto done;
}
resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
if (resNamePtr != NULL) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
}
}
*nsPtrPtr = (Tcl_Namespace *) nsPtr;
done:
iPtr->varFramePtr = savedFramePtr;
return result;
}
/*
*----------------------------------------------------------------------
*
* Tcl_NamespaceObjCmd --
*
* Invoked to implement the "namespace" command that creates, deletes,
* or manipulates Tcl namespaces. Handles the following syntax:
*
* namespace children ?name? ?pattern?
* namespace code arg
* namespace current
* namespace delete ?name name...?
* namespace ensemble subcommand ?arg...?
* namespace eval name arg ?arg...?
* namespace exists name
* namespace export ?-clear? ?pattern pattern...?
* namespace forget ?pattern pattern...?
* namespace import ?-force? ?pattern pattern...?
* namespace inscope name arg ?arg...?
* namespace origin name
* namespace parent ?name?
* namespace qualifiers string
* namespace tail string
* namespace which ?-command? ?-variable? name
*
* Results:
* Returns TCL_OK if the command is successful. Returns TCL_ERROR if
* anything goes wrong.
*
* Side effects:
* Based on the subcommand name (e.g., "import"), this procedure
* dispatches to a corresponding procedure NamespaceXXXCmd defined
* statically in this file. This procedure's side effects depend on
* whatever that subcommand procedure does. If there is an error, this
* procedure returns an error message in the interpreter's result
* object. Otherwise it may return a result in the interpreter's result
* object.
*
*----------------------------------------------------------------------
*/
int
Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Arbitrary value passed to cmd. */
Tcl_Interp *interp; /* Current interpreter. */
register int objc; /* Number of arguments. */
register Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *subCmds[] = {
"children", "code", "current", "delete", "ensemble",
"eval", "exists", "export", "forget", "import",
"inscope", "origin", "parent", "path", "qualifiers",
"tail", "which", (char *) NULL
};
enum NSSubCmdIdx {
NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
NSTailIdx, NSWhichIdx
};
int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
/*
* Return an index reflecting the particular subcommand.
*/
result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
"option", /*flags*/ 0, (int *) &index);
if (result != TCL_OK) {
return result;
}
switch (index) {
case NSChildrenIdx:
result = NamespaceChildrenCmd(clientData, interp, objc, objv);
break;
case NSCodeIdx:
result = NamespaceCodeCmd(clientData, interp, objc, objv);
break;
case NSCurrentIdx:
result = NamespaceCurrentCmd(clientData, interp, objc, objv);
break;
case NSDeleteIdx:
result = NamespaceDeleteCmd(clientData, interp, objc, objv);
break;
case NSEnsembleIdx:
result = NamespaceEnsembleCmd(clientData, interp, objc, objv);
break;
case NSEvalIdx:
result = NamespaceEvalCmd(clientData, interp, objc, objv);
break;
case NSExistsIdx:
result = NamespaceExistsCmd(clientData, interp, objc, objv);
break;
case NSExportIdx:
result = NamespaceExportCmd(clientData, interp, objc, objv);
break;
case NSForgetIdx:
result = NamespaceForgetCmd(clientData, interp, objc, objv);
break;
case NSImportIdx:
result = NamespaceImportCmd(clientData, interp, objc, objv);
break;
case NSInscopeIdx:
result = NamespaceInscopeCmd(clientData, interp, objc, objv);
break;
case NSOriginIdx:
result = NamespaceOriginCmd(clientData, interp, objc, objv);
break;
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;
case NSTailIdx:
result = NamespaceTailCmd(clientData, interp, objc, objv);
break;
case NSWhichIdx:
result = NamespaceWhichCmd(clientData, interp, objc, objv);
break;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceChildrenCmd --
*
* Invoked to implement the "namespace children" command that returns a
* list containing the fully-qualified names of the child namespaces of
* a given namespace. Handles the following syntax:
*
* namespace children ?name? ?pattern?
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceChildrenCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Namespace *nsPtr, *childNsPtr;
Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
char *pattern = NULL;
Tcl_DString buffer;
register Tcl_HashEntry *entryPtr;
Tcl_HashSearch search;
Tcl_Obj *listPtr, *elemPtr;
/*
* Get a pointer to the specified namespace, or the current namespace.
*/
if (objc == 2) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
} else if ((objc == 3) || (objc == 4)) {
if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
if (namespacePtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[2]),
"\" in namespace children command", (char *) NULL);
return TCL_ERROR;
}
nsPtr = (Namespace *) namespacePtr;
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
return TCL_ERROR;
}
/*
* Get the glob-style pattern, if any, used to narrow the search.
*/
Tcl_DStringInit(&buffer);
if (objc == 4) {
char *name = TclGetString(objv[3]);
if ((*name == ':') && (*(name+1) == ':')) {
pattern = name;
} else {
Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
if (nsPtr != globalNsPtr) {
Tcl_DStringAppend(&buffer, "::", 2);
}
Tcl_DStringAppend(&buffer, name, -1);
pattern = Tcl_DStringValue(&buffer);
}
}
/*
* Create a list containing the full names of all child namespaces
* whose names match the specified pattern, if any.
*/
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);
if ((pattern == NULL)
|| Tcl_StringMatch(childNsPtr->fullName, pattern)) {
elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
}
entryPtr = Tcl_NextHashEntry(&search);
}
searchDone:
Tcl_SetObjResult(interp, listPtr);
Tcl_DStringFree(&buffer);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceCodeCmd --
*
* Invoked to implement the "namespace code" command to capture the
* namespace context of a command. Handles the following syntax:
*
* namespace code arg
*
* Here "arg" can be a list. "namespace code arg" produces a result
* equivalent to that produced by the command
*
* list ::namespace inscope [namespace current] $arg
*
* However, if "arg" is itself a scoped value starting with
* "::namespace inscope", then the result is just "arg".
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error
* message as the result in the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCodeCmd(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 *currNsPtr;
Tcl_Obj *listPtr, *objPtr;
register char *arg, *p;
int length;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg");
return TCL_ERROR;
}
/*
* If "arg" is already a scoped value, then return it directly.
*/
arg = Tcl_GetStringFromObj(objv[2], &length);
while (*arg == ':') {
arg++;
length--;
}
if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) {
for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) {
/* empty body: skip over whitespace */
}
if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) {
Tcl_SetObjResult(interp, objv[2]);
return TCL_OK;
}
}
/*
* Otherwise, construct a scoped command by building a list with
* "namespace inscope", the full name of the current namespace, and
* the argument "arg". By constructing a list, we ensure that scoped
* commands are interpreted properly when they are executed later,
* by the "namespace inscope" command.
*/
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj("::namespace", -1));
Tcl_ListObjAppendElement(interp, listPtr,
Tcl_NewStringObj("inscope", -1));
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
objPtr = Tcl_NewStringObj("::", -1);
} else {
objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
}
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceCurrentCmd --
*
* Invoked to implement the "namespace current" command which returns
* the fully-qualified name of the current namespace. Handles the
* following syntax:
*
* namespace current
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceCurrentCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Namespace *currNsPtr;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
/*
* The "real" name of the global namespace ("::") is the null string,
* but we return "::" for it as a convenience to programmers. Note that
* "" and "::" are treated as synonyms by the namespace code so that it
* is still easy to do things like:
*
* namespace [namespace current]::bar { ... }
*/
currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
} else {
Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceDeleteCmd --
*
* Invoked to implement the "namespace delete" command to delete
* namespace(s). Handles the following syntax:
*
* namespace delete ?name name...?
*
* Each name identifies a namespace. It may include a sequence of
* namespace qualifiers separated by "::"s. If a namespace is found, it
* is deleted: all variables and procedures contained in that namespace
* are deleted. If that namespace is being used on the call stack, it
* is kept alive (but logically deleted) until it is removed from the
* call stack: that is, it can no longer be referenced by name but any
* currently executing procedure that refers to it is allowed to do so
* until the procedure returns. If the namespace can't be found, this
* procedure returns an error. If no namespaces are specified, this
* command does nothing.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Deletes the specified namespaces. If anything goes wrong, this
* procedure returns an error message in the interpreter's
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceDeleteCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
char *name;
register int i;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
return TCL_ERROR;
}
/*
* Destroying one namespace may cause another to be destroyed. Break
* this into two passes: first check to make sure that all namespaces on
* the command line are valid, and report any errors.
*/
for (i = 2; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /*flags*/ 0);
if (namespacePtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[i]),
"\" in namespace delete command", (char *) NULL);
return TCL_ERROR;
}
}
/*
* Okay, now delete each namespace.
*/
for (i = 2; i < objc; i++) {
name = TclGetString(objv[i]);
namespacePtr = Tcl_FindNamespace(interp, name,
(Tcl_Namespace *) NULL, /* flags */ 0);
if (namespacePtr) {
Tcl_DeleteNamespace(namespacePtr);
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceEvalCmd --
*
* Invoked to implement the "namespace eval" command. Executes
* commands in a namespace. If the namespace does not already exist,
* it is created. Handles the following syntax:
*
* namespace eval name arg ?arg...?
*
* If more than one arg argument is specified, the command that is
* executed is the result of concatenating the arguments together with
* a space between each argument.
*
* Results:
* Returns TCL_OK if the namespace is found and the commands are
* executed successfully. Returns TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns the result of the command in the interpreter's result
* object. If anything goes wrong, this procedure returns an error
* message as the result.
*
*----------------------------------------------------------------------
*/
static int
NamespaceEvalCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
CallFrame *framePtr, **framePtrPtr;
Tcl_Obj *objPtr;
int result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
/*
* Try to resolve the namespace reference, caching the result in the
* namespace object along the way.
*/
result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
/*
* If the namespace wasn't found, try to create it.
*/
if (namespacePtr == NULL) {
char *name = TclGetString(objv[2]);
namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL,
(Tcl_NamespaceDeleteProc *) NULL);
if (namespacePtr == NULL) {
return TCL_ERROR;
}
}
/*
* Make the specified namespace the current namespace and evaluate
* the command(s).
*/
/* This is needed to satisfy GCC 3.3's strict aliasing rules */
framePtrPtr = &framePtr;
result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, /*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return TCL_ERROR;
}
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts do not need to be incremented here */
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
/*
* More than one argument: concatenate them together with spaces
* between, then evaluate the result. Tcl_EvalObjEx will delete
* the object when it decrements its refcount after eval'ing it.
*/
objPtr = Tcl_ConcatObj(objc-3, objv+3);
result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
}
if (result == TCL_ERROR) {
Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace eval \"", -1);
Tcl_IncrRefCount(errorLine);
Tcl_IncrRefCount(msg);
TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
Tcl_AppendToObj(msg, "\" script line ", -1);
Tcl_AppendObjToObj(msg, errorLine);
Tcl_DecrRefCount(errorLine);
Tcl_AppendToObj(msg, ")", -1);
TclAppendObjToErrorInfo(interp, msg);
Tcl_DecrRefCount(msg);
}
/*
* Restore the previous "current" namespace.
*/
TclPopStackFrame(interp);
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceExistsCmd --
*
* Invoked to implement the "namespace exists" command that returns
* true if the given namespace currently exists, and false otherwise.
* Handles the following syntax:
*
* namespace exists name
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExistsCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
/*
* Check whether the given namespace exists
*/
if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(namespacePtr != NULL));
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceExportCmd --
*
* Invoked to implement the "namespace export" command that specifies
* which commands are exported from a namespace. The exported commands
* are those that can be imported into another namespace using
* "namespace import". Both commands defined in a namespace and
* commands the namespace has imported can be exported by a
* namespace. This command has the following syntax:
*
* namespace export ?-clear? ?pattern pattern...?
*
* Each pattern may contain "string match"-style pattern matching
* special characters, but the pattern may not include any namespace
* qualifiers: that is, the pattern must specify commands in the
* current (exporting) namespace. The specified patterns are appended
* onto the namespace's list of export patterns.
*
* To reset the namespace's export pattern list, specify the "-clear"
* flag.
*
* If there are no export patterns and the "-clear" flag isn't given,
* this command returns the namespace's current export list.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceExportCmd(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 *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp);
char *pattern, *string;
int resetListFirst = 0;
int firstArg, patternCt, i, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
/*
* Process the optional "-clear" argument.
*/
firstArg = 2;
if (firstArg < objc) {
string = TclGetString(objv[firstArg]);
if (strcmp(string, "-clear") == 0) {
resetListFirst = 1;
firstArg++;
}
}
/*
* If no pattern arguments are given, and "-clear" isn't specified,
* return the namespace's current export pattern list.
*/
patternCt = (objc - firstArg);
if (patternCt == 0) {
if (firstArg > 2) {
return TCL_OK;
} else { /* create list with export patterns */
Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
result = Tcl_AppendExportList(interp,
(Tcl_Namespace *) currNsPtr, listPtr);
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
}
/*
* Add each pattern to the namespace's export pattern list.
*/
for (i = firstArg; i < objc; i++) {
pattern = TclGetString(objv[i]);
result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
((i == firstArg)? resetListFirst : 0));
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceForgetCmd --
*
* Invoked to implement the "namespace forget" command to remove
* imported commands from a namespace. Handles the following syntax:
*
* namespace forget ?pattern pattern...?
*
* Each pattern is a name like "foo::*" or "a::b::x*". That is, the
* pattern may include the special pattern matching characters
* recognized by the "string match" command, but only in the command
* name at the end of the qualified name; the special pattern
* characters may not appear in a namespace name. All of the commands
* that match that pattern are checked to see if they have an imported
* command in the current namespace that refers to the matched
* command. If there is an alias, it is removed.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Imported commands are removed from the current namespace. If
* anything goes wrong, this procedure returns an error message in the
* interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceForgetCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *pattern;
register int i, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
pattern = TclGetString(objv[i]);
result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceImportCmd --
*
* Invoked to implement the "namespace import" command that imports
* commands into a namespace. Handles the following syntax:
*
* namespace import ?-force? ?pattern pattern...?
*
* Each pattern is a namespace-qualified name like "foo::*",
* "a::b::x*", or "bar::p". That is, the pattern may include the
* special pattern matching characters recognized by the "string match"
* command, but only in the command name at the end of the qualified
* name; the special pattern characters may not appear in a namespace
* name. All of the commands that match the pattern and which are
* exported from their namespace are made accessible from the current
* namespace context. This is done by creating a new "imported command"
* in the current namespace that points to the real command in its
* original namespace; when the imported command is called, it invokes
* the real command.
*
* If an imported command conflicts with an existing command, it is
* treated as an error. But if the "-force" option is included, then
* existing commands are overwritten by the imported commands.
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Adds imported commands to the current namespace. If anything goes
* wrong, this procedure returns an error message in the interpreter's
* result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceImportCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register int i = 0,
result = TCL_OK;
int allowOverwrite = 0,
returnOrigins = 0,
firstArg = 2;
char *string = (char *) NULL,
*pattern = (char *) NULL;
Namespace *currNsPtr = (Namespace*) NULL;
Command *command = (Command *) NULL;
Tcl_HashSearch search;
Tcl_HashEntry *hPtr = (Tcl_HashEntry *) NULL;
Tcl_Obj *importedList = (Tcl_Obj *) NULL;
*cmdNameObj = (Tcl_Obj *) NULL;
Tcl_Command token;
if (objc < 2) {
Tcl_WrongNumArgs(
interp,
2, objv,
"?-origins | ?-force? pattern ?pattern...??"
);
return TCL_ERROR;
}
/*
* Detect the optional arguments "-force" and "-origins"
* as the first argument.
*/
if (firstArg < objc) {
string = TclGetString(objv[firstArg]);
if (*string == '-') {
if (strcmp(string, "-force") == 0) {
if ( objc <= 3 ) {
Tcl_WrongNumArgs(
interp,
3, objv,
NULL
);
return TCL_ERROR;
}
allowOverwrite = 1;
firstArg++;
} elseif (strcmp(string, "-origins") == 0) {
if ( objc != 3 ) {
Tcl_WrongNumArgs(
interp,
3, objv,
NULL
);
return TCL_ERROR;
}
returnOrigins = 1;
} else {
Tcl_ResetResult( interp );
Tcl_SetAppendResult(
interp,
"bad option \"",
string,
"\": must be -force, -origins, or omitted"
);
return TCL_ERROR;
}
}
}
if ((objc == 2) ||
((objc == 3) && (returnOrigins == 1) {
/* get the current namespace and the first command of this
* namespace
*/
currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp)
hPtr = Tcl_FirstHashEntry(currNsPtr->cmdTable, &search);
/* initialize the list of imported commands
*/
importedList = Tcl_NewObj();
/* loop over the commands of the current namespace
* to test if they are imported and than, if so,
* to get their absolute (original) names
*/
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
token = (Tcl_Command) Tcl_GetHashValue(hPtr);
command = (Command *) token;
if (command->flags & CMD_IS_IMPORTED) {
if (returnOrigins == 1) {
/* get the origin of the imported namespace command
*/
token = TclGetOriginalCommand(token);
}
/* get the absolute/full name of the imported
* namespace command
*/
cmdNameObj = Tcl_NewObj();
Tcl_GetCommandFullName(interp, token, cmdNameObj);
result = Tcl_ListObjAppendElement(
interp, importedList, cmdNameObj
);
if (result == TCL_ERROR) {
Tcl_DecrRefCount( importedList );
return TCL_ERROR;
}
}
}
Tcl_SetObjResult(interp, importedList);
return TCL_OK;
}
/*
* Handle the imports for each of the patterns.
*/
for (i = firstArg; i < objc; i++) {
pattern = TclGetString(objv[i]);
result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
allowOverwrite);
if (result != TCL_OK) {
return result;
}
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceInscopeCmd --
*
* Invoked to implement the "namespace inscope" command that executes a
* script in the context of a particular namespace. This command is not
* expected to be used directly by programmers; calls to it are
* generated implicitly when programs use "namespace code" commands
* to register callback scripts. Handles the following syntax:
*
* namespace inscope name arg ?arg...?
*
* The "namespace inscope" command is much like the "namespace eval"
* command except that it has lappend semantics and the namespace must
* already exist. It treats the first argument as a list, and appends
* any arguments after the first onto the end as proper list elements.
* For example,
*
* namespace inscope ::foo a b c d
*
* is equivalent to
*
* namespace eval ::foo [concat a [list b c d]]
*
* This lappend semantics is important because many callback scripts
* are actually prefixes.
*
* Results:
* Returns TCL_OK to indicate success, or TCL_ERROR to indicate
* failure.
*
* Side effects:
* Returns a result in the Tcl interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceInscopeCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *namespacePtr;
Tcl_CallFrame *framePtr;
int i, result;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
/*
* Resolve the namespace reference.
*/
result = TclGetNamespaceFromObj(interp, objv[2], &namespacePtr);
if (result != TCL_OK) {
return result;
}
if (namespacePtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"", TclGetString(objv[2]),
"\" in inscope namespace command", (char *) NULL);
return TCL_ERROR;
}
/*
* Make the specified namespace the current namespace.
*/
result = TclPushStackFrame(interp, &framePtr, namespacePtr,
/*isProcCallFrame*/ 0);
if (result != TCL_OK) {
return result;
}
/*
* Execute the command. If there is just one argument, just treat it as
* a script and evaluate it. Otherwise, create a list from the arguments
* after the first one, then concatenate the first argument and the list
* of extra arguments to form the command to evaluate.
*/
if (objc == 4) {
result = Tcl_EvalObjEx(interp, objv[3], 0);
} else {
Tcl_Obj *concatObjv[2];
register Tcl_Obj *listPtr, *cmdObjPtr;
listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
for (i = 4; i < objc; i++) {
result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]);
if (result != TCL_OK) {
Tcl_DecrRefCount(listPtr); /* free unneeded obj */
return result;
}
}
concatObjv[0] = objv[3];
concatObjv[1] = listPtr;
cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
Tcl_DecrRefCount(listPtr); /* we're done with the list object */
}
if (result == TCL_ERROR) {
Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine);
Tcl_Obj *msg = Tcl_NewStringObj("\n (in namespace inscope \"", -1);
Tcl_IncrRefCount(errorLine);
Tcl_IncrRefCount(msg);
TclAppendLimitedToObj(msg, namespacePtr->fullName, -1, 200, "");
Tcl_AppendToObj(msg, "\" script line ", -1);
Tcl_AppendObjToObj(msg, errorLine);
Tcl_DecrRefCount(errorLine);
Tcl_AppendToObj(msg, ")", -1);
TclAppendObjToErrorInfo(interp, msg);
Tcl_DecrRefCount(msg);
}
/*
* Restore the previous "current" namespace.
*/
TclPopStackFrame(interp);
return result;
}
/*
*----------------------------------------------------------------------
*
* NamespaceOriginCmd --
*
* Invoked to implement the "namespace origin" command to return the
* fully-qualified name of the "real" command to which the specified
* "imported command" refers. Handles the following syntax:
*
* namespace origin name
*
* Results:
* An imported command is created in an namespace when that namespace
* imports a command from another namespace. If a command is imported
* into a sequence of namespaces a, b,...,n where each successive
* namespace just imports the command from the previous namespace, this
* command returns the fully-qualified name of the original command in
* the first namespace, a. If "name" does not refer to an alias, its
* fully-qualified name is returned. The returned name is stored in the
* interpreter's result object. This procedure returns TCL_OK if
* successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* If anything goes wrong, this procedure returns an error message in
* the interpreter's result object.
*
*----------------------------------------------------------------------
*/
static int
NamespaceOriginCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Command command, origCommand;
Tcl_Obj *resultPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
command = Tcl_GetCommandFromObj(interp, objv[2]);
if (command == (Tcl_Command) NULL) {
Tcl_AppendResult(interp, "invalid command name \"",
TclGetString(objv[2]), "\"", (char *) NULL);
return TCL_ERROR;
}
origCommand = TclGetOriginalCommand(command);
resultPtr = Tcl_NewObj();
if (origCommand == (Tcl_Command) NULL) {
/*
* The specified command isn't an imported command. Return the
* command's name qualified by the full name of the namespace it
* was defined in.
*/
Tcl_GetCommandFullName(interp, command, resultPtr);
} else {
Tcl_GetCommandFullName(interp, origCommand, resultPtr);
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceParentCmd --
*
* Invoked to implement the "namespace parent" command that returns the
* fully-qualified name of the parent namespace for a specified
* namespace. Handles the following syntax:
*
* namespace parent ?name?
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceParentCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Namespace *nsPtr;
int result;
if (objc == 2) {
nsPtr = Tcl_GetCurrentNamespace(interp);
} else if (objc == 3) {
result = TclGetNamespaceFromObj(interp, objv[2], &nsPtr);
if (result != TCL_OK) {
return result;
}
if (nsPtr == NULL) {
Tcl_AppendResult(interp, "unknown namespace \"",
TclGetString(objv[2]),
"\" in namespace parent command", (char *) NULL);
return TCL_ERROR;
}
} else {
Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
/*
* Report the parent of the specified namespace.
*/
if (nsPtr->parentPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
nsPtr->parentPtr->fullName, -1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* 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
* any leading namespace qualifiers in a string. These qualifiers are
* namespace names separated by "::"s. For example, for "::foo::p" this
* command returns "::foo", and for "::" it returns "". This command
* is the complement of the "namespace tail" command. Note that this
* command does not check whether the "namespace" names are, in fact,
* the names of currently defined namespaces. Handles the following
* syntax:
*
* namespace qualifiers string
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceQualifiersCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *name, *p;
int length;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
/*
* Find the end of the string, then work backward and find
* the start of the last "::" qualifier.
*/
name = TclGetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p >= name) {
if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
p -= 2; /* back up over the :: */
while ((p >= name) && (*p == ':')) {
p--; /* back up over the preceeding : */
}
break;
}
}
if (p >= name) {
length = p-name+1;
Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceTailCmd --
*
* Invoked to implement the "namespace tail" command that returns the
* trailing name at the end of a string with "::" namespace
* qualifiers. These qualifiers are namespace names separated by
* "::"s. For example, for "::foo::p" this command returns "p", and for
* "::" it returns "". This command is the complement of the "namespace
* qualifiers" command. Note that this command does not check whether
* the "namespace" names are, in fact, the names of currently defined
* namespaces. Handles the following syntax:
*
* namespace tail string
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceTailCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *name, *p;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
/*
* Find the end of the string, then work backward and find the
* last "::" qualifier.
*/
name = TclGetString(objv[2]);
for (p = name; *p != '\0'; p++) {
/* empty body */
}
while (--p > name) {
if ((*p == ':') && (*(p-1) == ':')) {
p++; /* just after the last "::" */
break;
}
}
if (p >= name) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NamespaceWhichCmd --
*
* Invoked to implement the "namespace which" command that returns the
* fully-qualified name of a command or variable. If the specified
* command or variable does not exist, it returns "". Handles the
* following syntax:
*
* namespace which ?-command? ?-variable? name
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Returns a result in the interpreter's result object. If anything
* goes wrong, the result is an error message.
*
*----------------------------------------------------------------------
*/
static int
NamespaceWhichCmd(dummy, interp, objc, objv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
static CONST char *opts[] = {
"-command", "-variable", NULL
};
int lookupType = 0;
Tcl_Obj *resultPtr;
if (objc < 3 || objc > 4) {
badArgs:
Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name");
return TCL_ERROR;
} else if (objc == 4) {
/*
* Look for a flag controlling the lookup.
*/
if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
&lookupType) != TCL_OK) {
/*
* Preserve old style of error message!
*/
Tcl_ResetResult(interp);
goto badArgs;
}
}
resultPtr = Tcl_NewObj();
switch (lookupType) {
case 0: { /* -command */
Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);
if (cmd != (Tcl_Command) NULL) {
Tcl_GetCommandFullName(interp, cmd, resultPtr);
}
break;
}
case 1: { /* -variable */
Tcl_Var var = Tcl_FindNamespaceVar(interp,
TclGetString(objv[objc-1]), NULL, /*flags*/ 0);
if (var != (Tcl_Var) NULL) {
Tcl_GetVariableFullName(interp, var, resultPtr);
}
break;
}
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* FreeNsNameInternalRep --
*
* Frees the resources associated with a nsName object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Decrements the ref count of any Namespace structure pointed
* to by the nsName's internal representation. If there are no more
* references to the namespace, it's structure will be freed.
*
*----------------------------------------------------------------------
*/
static void
FreeNsNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* nsName object with internal
* representation to free */
{
register ResolvedNsName *resNamePtr = (ResolvedNsName *)
objPtr->internalRep.otherValuePtr;
Namespace *nsPtr;
/*
* Decrement the reference count of the namespace. If there are no
* more references, free it up.
*/
if (resNamePtr != NULL) {
resNamePtr->refCount--;
if (resNamePtr->refCount == 0) {
/*
* Decrement the reference count for the cached namespace. If
* the namespace is dead, and there are no more references to
* it, free it.
*/
nsPtr = resNamePtr->nsPtr;
nsPtr->refCount--;
if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
ckfree((char *) resNamePtr);
}
}
}
/*
*----------------------------------------------------------------------
*
* DupNsNameInternalRep --
*
* Initializes the internal representation of a nsName object to a copy
* of the internal representation of another nsName object.
*
* Results:
* None.
*
* Side effects:
* copyPtr's internal rep is set to refer to the same namespace
* referenced by srcPtr's internal rep. Increments the ref count of
* the ResolvedNsName structure used to hold the namespace reference.
*
*----------------------------------------------------------------------
*/
static void
DupNsNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedNsName *resNamePtr = (ResolvedNsName *)
srcPtr->internalRep.otherValuePtr;
copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
if (resNamePtr != NULL) {
resNamePtr->refCount++;
}
copyPtr->typePtr = &tclNsNameType;
}
/*
*----------------------------------------------------------------------
*
* SetNsNameFromAny --
*
* Attempt to generate a nsName internal representation for a
* Tcl object.
*
* Results:
* Returns TCL_OK if the value could be converted to a proper
* namespace reference. Otherwise, it returns TCL_ERROR, along
* with an error message in the interpreter's result object.
*
* Side effects:
* If successful, the object is made a nsName object. Its internal rep
* is set to point to a ResolvedNsName, which contains a cached pointer
* to the Namespace. Reference counts are kept on both the
* ResolvedNsName and the Namespace, so we can keep track of their
* usage and free them when appropriate.
*
*----------------------------------------------------------------------
*/
static int
SetNsNameFromAny(interp, objPtr)
Tcl_Interp *interp; /* Points to the namespace in which to
* resolve name. Also used for error
* reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
char *name;
CONST char *dummy;
Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
register ResolvedNsName *resNamePtr;
/*
* Get the string representation. Make it up-to-date if necessary.
*/
name = objPtr->bytes;
if (name == NULL) {
name = TclGetString(objPtr);
}
/*
* Look for the namespace "name" in the current namespace. If there is
* an error parsing the (possibly qualified) name, return an error.
* If the namespace isn't found, we convert the object to an nsName
* object with a NULL ResolvedNsName* internal rep.
*/
TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
/*
* If we found a namespace, then create a new ResolvedNsName structure
* that holds a reference to it.
*/
if (nsPtr != NULL) {
Namespace *currNsPtr =
(Namespace *) Tcl_GetCurrentNamespace(interp);
nsPtr->refCount++;
resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
resNamePtr->nsPtr = nsPtr;
resNamePtr->nsId = nsPtr->nsId;
resNamePtr->refNsPtr = currNsPtr;
resNamePtr->refCount = 1;
} else {
resNamePtr = NULL;
}
/*
* Free the old internalRep before setting the new one.
* We do this as late as possible to allow the conversion code
* (in particular, Tcl_GetStringFromObj) to use that old internalRep.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
objPtr->typePtr = &tclNsNameType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* UpdateStringOfNsName --
*
* Updates the string representation for a nsName object.
* Note: This procedure does not free an existing old string rep
* so storage will be lost if this has not already been done.
*
* Results:
* None.
*
* Side effects:
* The object's string is set to a copy of the fully qualified
* namespace name.
*
*----------------------------------------------------------------------
*/
static void
UpdateStringOfNsName(objPtr)
register Tcl_Obj *objPtr; /* nsName object with string rep to update. */
{
ResolvedNsName *resNamePtr =
(ResolvedNsName *) objPtr->internalRep.otherValuePtr;
register Namespace *nsPtr;
char *name = "";
int length;
if ((resNamePtr != NULL)
&& (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
nsPtr = resNamePtr->nsPtr;
if (nsPtr->flags & NS_DEAD) {
nsPtr = NULL;
}
if (nsPtr != NULL) {
name = nsPtr->fullName;
}
}
/*
* The following sets the string rep to an empty string on the heap
* if the internal rep is NULL.
*/
length = strlen(name);
if (length == 0) {
objPtr->bytes = tclEmptyStringRep;
} else {
objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
objPtr->bytes[length] = '\0';
}
objPtr->length = length;
}
/*
*----------------------------------------------------------------------
*
* NamespaceEnsembleCmd --
*
* Invoked to implement the "namespace ensemble" command that
* creates and manipulates ensembles built on top of namespaces.
* Handles the following syntax:
*
* namespace ensemble name ?dictionary?
*
* Results:
* Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
*
* Side effects:
* Creates the ensemble for the namespace if one did not
* previously exist. Alternatively, alters the way that the
* ensemble's subcommand => implementation prefix is configured.
*
*----------------------------------------------------------------------
*/
static int
NamespaceEnsembleCmd(dummy, interp, objc, objv)
ClientData dummy;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
Namespace *nsPtr;
Tcl_Command token;
static CONST char *subcommands[] = {
"configure", "create", "exists", NULL
};
enum EnsSubcmds {
ENS_CONFIG, ENS_CREATE, ENS_EXISTS
};
static CONST char *createOptions[] = {
"-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL
};
enum EnsCreateOpts {
CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
};
static CONST char *configOptions[] = {
"-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL
};
enum EnsConfigOpts {
CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN
};
int index;
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
if (!Tcl_InterpDeleted(interp)) {
Tcl_AppendResult(interp,
"tried to manipulate ensemble of deleted namespace", NULL);
}
return TCL_ERROR;
}
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum EnsSubcmds) index) {
case ENS_CREATE: {
char *name;
Tcl_DictSearch search;
Tcl_Obj *listObj;
int done, len, allocatedMapFlag = 0;
/*
* Defaults
*/
Tcl_Obj *subcmdObj = NULL;
Tcl_Obj *mapObj = NULL;
int permitPrefix = 1;
Tcl_Obj *unknownObj = NULL;
objv += 3;
objc -= 3;
/*
* Work out what name to use for the command to create. If
* supplied, it is either fully specified or relative to the
* current namespace. If not supplied, it is exactly the name
* of the current namespace.
*/
name = nsPtr->fullName;
/*
* Parse the option list, applying type checks as we go. Note
* that we are not incrementing any reference counts in the
* objects at this stage, so the presence of an option
* multiple times won't cause any memory leaks.
*/
for (; objc>1 ; objc-=2,objv+=2 ) {
if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
0, &index) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
switch ((enum EnsCreateOpts) index) {
case CRT_CMD:
name = TclGetString(objv[1]);
continue;
case CRT_SUBCMDS:
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CRT_MAP: {
Tcl_Obj *patchedDict = NULL, *subcmdObj;
/*
* Verify that the map is sensible.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&subcmdObj, &listObj, &done) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (done) {
mapObj = NULL;
continue;
}
do {
Tcl_Obj **listv;
char *cmd;
if (Tcl_ListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (len < 1) {
Tcl_SetResult(interp,
"ensemble subcommand implementations "
"must be non-empty lists", TCL_STATIC);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
Tcl_Obj *newCmd =
Tcl_NewStringObj(nsPtr->fullName, -1);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
}
Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
} while (!done);
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
}
case CRT_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
continue;
case CRT_UNKNOWN:
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
/*
* Create the ensemble. Note that this might delete another
* ensemble linked to the same namespace, so we must be
* careful. However, we should be OK because we only link the
* namespace into the list once we've created it (and after
* any deletions have occurred.)
*/
token = Tcl_CreateEnsemble(interp, name, NULL,
(permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
Tcl_SetEnsembleMappingDict(interp, token, mapObj);
Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
/*
* Tricky! Rely on the object result not being shared!
*/
Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
return TCL_OK;
}
case ENS_EXISTS:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
return TCL_OK;
case ENS_CONFIG:
if (objc < 4 || (objc != 5 && objc & 1)) {
Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
return TCL_ERROR;
}
token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
if (token == NULL) {
return TCL_ERROR;
}
if (objc == 5) {
Tcl_Obj *resultObj;
if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum EnsConfigOpts) index) {
case CONF_SUBCMDS:
Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_MAP:
Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
case CONF_NAMESPACE: {
Tcl_Namespace *namespacePtr;
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName,
TCL_VOLATILE);
break;
}
case CONF_PREFIX: {
int flags;
Tcl_GetEnsembleFlags(NULL, token, &flags);
Tcl_SetObjResult(interp,
Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
break;
}
case CONF_UNKNOWN:
Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
if (resultObj != NULL) {
Tcl_SetObjResult(interp, resultObj);
}
break;
}
return TCL_OK;
} else if (objc == 4) {
/*
* Produce list of all information.
*/
Tcl_Obj *resultObj, *tmpObj;
Tcl_Namespace *namespacePtr;
int flags;
TclNewObj(resultObj);
/* -map option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(configOptions[CONF_MAP], -1));
Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
if (tmpObj != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
} else {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
}
/* -namespace option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName,
-1));
/* -prefix option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));
Tcl_GetEnsembleFlags(NULL, token, &flags);
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
/* -subcommands option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
if (tmpObj != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
} else {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
}
/* -unknown option */
Tcl_ListObjAppendElement(NULL, resultObj,
Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
if (tmpObj != NULL) {
Tcl_ListObjAppendElement(NULL, resultObj, tmpObj);
} else {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewObj());
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
} else {
Tcl_DictSearch search;
Tcl_Obj *listObj;
int done, len, allocatedMapFlag = 0;
/*
* Defaults
*/
Tcl_Obj *subcmdObj, *mapObj, *unknownObj;
int permitPrefix, flags;
Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
Tcl_GetEnsembleFlags(NULL, token, &flags);
permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
objv += 4;
objc -= 4;
/*
* Parse the option list, applying type checks as we go.
* Note that we are not incrementing any reference counts
* in the objects at this stage, so the presence of an
* option multiple times won't cause any memory leaks.
*/
for (; objc>0 ; objc-=2,objv+=2 ) {
if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
"option", 0, &index) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
switch ((enum EnsConfigOpts) index) {
case CONF_SUBCMDS:
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
subcmdObj = (len > 0 ? objv[1] : NULL);
continue;
case CONF_MAP: {
Tcl_Obj *patchedDict = NULL, *subcmdObj;
/*
* Verify that the map is sensible.
*/
if (Tcl_DictObjFirst(interp, objv[1], &search,
&subcmdObj, &listObj, &done) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (done) {
mapObj = NULL;
continue;
}
do {
Tcl_Obj **listv;
char *cmd;
if (Tcl_ListObjGetElements(interp, listObj, &len,
&listv) != TCL_OK) {
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
if (len < 1) {
Tcl_SetResult(interp,
"ensemble subcommand implementations "
"must be non-empty lists", TCL_STATIC);
Tcl_DictObjDone(&search);
if (patchedDict) {
Tcl_DecrRefCount(patchedDict);
}
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
cmd = TclGetString(listv[0]);
if (!(cmd[0] == ':' && cmd[1] == ':')) {
Tcl_Obj *newList = Tcl_NewListObj(len, listv);
Tcl_Obj *newCmd =
Tcl_NewStringObj(nsPtr->fullName, -1);
if (nsPtr->parentPtr) {
Tcl_AppendStringsToObj(newCmd, "::", NULL);
}
Tcl_AppendObjToObj(newCmd, listv[0]);
Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
if (patchedDict == NULL) {
patchedDict = Tcl_DuplicateObj(objv[1]);
}
Tcl_DictObjPut(NULL, patchedDict, subcmdObj,
newList);
}
Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
} while (!done);
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
mapObj = (patchedDict ? patchedDict : objv[1]);
if (patchedDict) {
allocatedMapFlag = 1;
}
continue;
}
case CONF_NAMESPACE:
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
Tcl_AppendResult(interp, "option -namespace is read-only",
NULL);
return TCL_ERROR;
case CONF_PREFIX:
if (Tcl_GetBooleanFromObj(interp, objv[1],
&permitPrefix) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
continue;
case CONF_UNKNOWN:
if (Tcl_ListObjLength(interp, objv[1], &len) != TCL_OK) {
if (allocatedMapFlag) {
Tcl_DecrRefCount(mapObj);
}
return TCL_ERROR;
}
unknownObj = (len > 0 ? objv[1] : NULL);
continue;
}
}
/*
* Update the namespace now that we've finished the
* parsing stage.
*/
flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
: flags&~TCL_ENSEMBLE_PREFIX);
Tcl_SetEnsembleSubcommandList(NULL, token, subcmdObj);
Tcl_SetEnsembleMappingDict(NULL, token, mapObj);
Tcl_SetEnsembleUnknownHandler(NULL, token, unknownObj);
Tcl_SetEnsembleFlags(NULL, token, flags);
return TCL_OK;
}
default:
Tcl_Panic("unexpected ensemble command");
}
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_CreateEnsemble --
*
* Create a simple ensemble attached to the given namespace.
*
* Results:
* The token for the command created.
*
* Side effects:
* The ensemble is created and marked for compilation.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_CreateEnsemble(interp, name, namespacePtr, flags)
Tcl_Interp *interp;
CONST char *name;
Tcl_Namespace *namespacePtr;
int flags;
{
Namespace *nsPtr = (Namespace *) namespacePtr;
EnsembleConfig *ensemblePtr =
(EnsembleConfig *) ckalloc(sizeof(EnsembleConfig));
Tcl_Obj *nameObj = NULL;
if (nsPtr == NULL) {
nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
}
/*
* Make the name of the ensemble into a fully qualified name.
* This might allocate a temporary object.
*/
if (!(name[0] == ':' && name[1] == ':')) {
nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
if (nsPtr->parentPtr == NULL) {
Tcl_AppendStringsToObj(nameObj, name, NULL);
} else {
Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
}
Tcl_IncrRefCount(nameObj);
name = TclGetString(nameObj);
}
ensemblePtr->nsPtr = nsPtr;
ensemblePtr->epoch = 0;
Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
ensemblePtr->subcommandArrayPtr = NULL;
ensemblePtr->subcmdList = NULL;
ensemblePtr->subcommandDict = NULL;
ensemblePtr->flags = flags;
ensemblePtr->unknownHandler = NULL;
ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
NsEnsembleImplementationCmd, (ClientData)ensemblePtr,
DeleteEnsembleConfig);
ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
/*
* Trigger an eventual recomputation of the ensemble command
* set. Note that this is slightly tricky, as it means that
* we are not actually counting the number of namespace export
* actions, but it is the simplest way to go!
*/
nsPtr->exportLookupEpoch++;
if (nameObj != NULL) {
TclDecrRefCount(nameObj);
}
return ensemblePtr->token;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleSubcommandList --
*
* Set the subcommand list for a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble or the subcommand list - if non-NULL - is not a list).
*
* Side effects:
* The ensemble is updated and marked for recompilation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleSubcommandList(interp, token, subcmdList)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj *subcmdList;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
if (subcmdList != NULL) {
int length;
if (Tcl_ListObjLength(interp, subcmdList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
subcmdList = NULL;
}
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
oldList = ensemblePtr->subcmdList;
ensemblePtr->subcmdList = subcmdList;
if (subcmdList != NULL) {
Tcl_IncrRefCount(subcmdList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
}
/*
* Trigger an eventual recomputation of the ensemble command
* set. Note that this is slightly tricky, as it means that
* we are not actually counting the number of namespace export
* actions, but it is the simplest way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleMappingDict --
*
* Set the mapping dictionary for a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble or the mapping - if non-NULL - is not a dict).
*
* Side effects:
* The ensemble is updated and marked for recompilation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleMappingDict(interp, token, mapDict)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj *mapDict;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldDict;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
if (mapDict != NULL) {
int size;
if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
return TCL_ERROR;
}
if (size < 1) {
mapDict = NULL;
}
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
oldDict = ensemblePtr->subcommandDict;
ensemblePtr->subcommandDict = mapDict;
if (mapDict != NULL) {
Tcl_IncrRefCount(mapDict);
}
if (oldDict != NULL) {
TclDecrRefCount(oldDict);
}
/*
* Trigger an eventual recomputation of the ensemble command
* set. Note that this is slightly tricky, as it means that
* we are not actually counting the number of namespace export
* actions, but it is the simplest way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleUnknownHandler --
*
* Set the unknown handler for a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble or the unknown handler - if non-NULL - is not a list).
*
* Side effects:
* The ensemble is updated and marked for recompilation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleUnknownHandler(interp, token, unknownList)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj *unknownList;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
Tcl_Obj *oldList;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
if (unknownList != NULL) {
int length;
if (Tcl_ListObjLength(interp, unknownList, &length) != TCL_OK) {
return TCL_ERROR;
}
if (length < 1) {
unknownList = NULL;
}
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
oldList = ensemblePtr->unknownHandler;
ensemblePtr->unknownHandler = unknownList;
if (unknownList != NULL) {
Tcl_IncrRefCount(unknownList);
}
if (oldList != NULL) {
TclDecrRefCount(oldList);
}
/*
* Trigger an eventual recomputation of the ensemble command
* set. Note that this is slightly tricky, as it means that
* we are not actually counting the number of namespace export
* actions, but it is the simplest way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_SetEnsembleFlags --
*
* Set the flags for a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble).
*
* Side effects:
* The ensemble is updated and marked for recompilation.
*
*----------------------------------------------------------------------
*/
int
Tcl_SetEnsembleFlags(interp, token, flags)
Tcl_Interp *interp;
Tcl_Command token;
int flags;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
/*
* This API refuses to set the ENS_DEAD flag...
*/
ensemblePtr->flags &= ENS_DEAD;
ensemblePtr->flags |= flags & ~ENS_DEAD;
/*
* Trigger an eventual recomputation of the ensemble command
* set. Note that this is slightly tricky, as it means that
* we are not actually counting the number of namespace export
* actions, but it is the simplest way to go!
*/
ensemblePtr->nsPtr->exportLookupEpoch++;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEnsembleSubcommandList --
*
* Get the list of subcommands associated with a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble). The list of subcommands is returned by updating the
* variable pointed to by the last parameter (NULL if this is to
* be derived from the mapping dictionary or the associated
* namespace's exported commands).
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleSubcommandList(interp, token, subcmdListPtr)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj **subcmdListPtr;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
*subcmdListPtr = ensemblePtr->subcmdList;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEnsembleMappingDict --
*
* Get the command mapping dictionary associated with a
* particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble). The mapping dict is returned by updating the
* variable pointed to by the last parameter (NULL if none is
* installed).
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleMappingDict(interp, token, mapDictPtr)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj **mapDictPtr;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
*mapDictPtr = ensemblePtr->subcommandDict;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEnsembleUnknownHandler --
*
* Get the unknown handler associated with a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble). The unknown handler is returned by updating the
* variable pointed to by the last parameter (NULL if no handler
* is installed).
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleUnknownHandler(interp, token, unknownListPtr)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Obj **unknownListPtr;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
*unknownListPtr = ensemblePtr->unknownHandler;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEnsembleFlags --
*
* Get the flags for a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble). The flags are returned by updating the variable
* pointed to by the last parameter.
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleFlags(interp, token, flagsPtr)
Tcl_Interp *interp;
Tcl_Command token;
int *flagsPtr;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
*flagsPtr = ensemblePtr->flags;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_GetEnsembleNamespace --
*
* Get the namespace associated with a particular ensemble.
*
* Results:
* Tcl result code (error if command token does not indicate an
* ensemble). Namespace is returned by updating the variable
* pointed to by the last parameter.
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr)
Tcl_Interp *interp;
Tcl_Command token;
Tcl_Namespace **namespacePtrPtr;
{
Command *cmdPtr = (Command *) token;
EnsembleConfig *ensemblePtr;
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (interp != NULL) {
Tcl_AppendResult(interp, "command is not an ensemble", NULL);
}
return TCL_ERROR;
}
ensemblePtr = (EnsembleConfig *) cmdPtr->objClientData;
*namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* Tcl_FindEnsemble --
*
* Given a command name, get the ensemble token for it, allowing
* for [namespace import]s. [Bug 1017022]
*
* Results:
* The token for the ensemble command with the given name, or
* NULL if the command either does not exist or is not an
* ensemble (when an error message will be written into the
* interp if thats non-NULL).
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_FindEnsemble(interp, cmdNameObj, flags)
Tcl_Interp *interp; /* Where to do the lookup, and where
* to write the errors if
* TCL_LEAVE_ERR_MSG is set in the
* flags. */
Tcl_Obj *cmdNameObj; /* Name of command to look up. */
int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other
* flags are probably not useful. */
{
Command *cmdPtr;
cmdPtr = (Command *)
Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
if (cmdPtr == NULL) {
return NULL;
}
if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
/*
* Reuse existing infrastructure for following import link
* chains rather than duplicating it.
*/
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
if (flags & TCL_LEAVE_ERR_MSG) {
Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
"\" is not an ensemble command", NULL);
}
return NULL;
}
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* Tcl_IsEnsemble --
*
* Simple test for ensemble-hood that takes into account imported
* ensemble commands as well.
*
* Results:
* Boolean value
*
* Side effects:
* None
*
*----------------------------------------------------------------------
*/
int
Tcl_IsEnsemble(token)
Tcl_Command token;
{
Command *cmdPtr = (Command *) token;
if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
return 1;
}
cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
return 0;
}
return 1;
}
/*
*----------------------------------------------------------------------
*
* NsEnsembleImplementationCmd --
*
* Implements an ensemble of commands (being those exported by a
* namespace other than the global namespace) as a command with
* the same (short) name as the namespace in the parent namespace.
*
* Results:
* A standard Tcl result code. Will be TCL_ERROR if the command
* is not an unambiguous prefix of any command exported by the
* ensemble's namespace.
*
* Side effects:
* Depends on the command within the namespace that gets executed.
* If the ensemble itself returns TCL_ERROR, a descriptive error
* message will be placed in the interpreter's result.
*
*----------------------------------------------------------------------
*/
static int
NsEnsembleImplementationCmd(clientData, interp, objc, objv)
ClientData clientData;
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData;
/* The ensemble itself. */
Tcl_Obj **tempObjv; /* Space used to construct the list of
* arguments to pass to the command
* that implements the ensemble
* subcommand. */
int result; /* The result of the subcommand
* execution. */
Tcl_Obj *prefixObj; /* An object containing the prefix
* words of the command that implements
* the subcommand. */
Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
* specified but not yet cached command
* names. */
Tcl_Obj **prefixObjv; /* The list of objects to substitute in
* as the target command prefix. */
int prefixObjc; /* Size of prefixObjv of course! */
int reparseCount = 0; /* Number of reparses. */
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
return TCL_ERROR;
}
restartEnsembleParse:
if (ensemblePtr->nsPtr->flags & NS_DEAD) {
/*
* Don't know how we got here, but make things give up quickly.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_AppendResult(interp,
"ensemble activated for deleted namespace", NULL);
}
return TCL_ERROR;
}
if (ensemblePtr->epoch != ensemblePtr->nsPtr->exportLookupEpoch) {
ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
BuildEnsembleConfig(ensemblePtr);
} else {
/*
* Table of subcommands is still valid; therefore there might
* be a valid cache of discovered information which we can
* reuse. Do the check here, and if we're still valid, we can
* jump straight to the part where we do the invocation of the
* subcommand.
*/
if (objv[1]->typePtr == &tclEnsembleCmdType) {
EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
objv[1]->internalRep.otherValuePtr;
if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
ensembleCmd->epoch == ensemblePtr->epoch &&
ensembleCmd->token == ensemblePtr->token) {
prefixObj = ensembleCmd->realPrefixObj;
Tcl_IncrRefCount(prefixObj);
goto runResultingSubcommand;
}
}
}
/*
* Look in the hashtable for the subcommand name; this is the
* fastest way of all.
*/
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
TclGetString(objv[1]));
if (hPtr != NULL) {
char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
/*
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
} else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
/*
* Can't find and we are prohibited from using unambiguous prefixes.
*/
goto unknownOrAmbiguousSubcommand;
} else {
/*
* If we've not already confirmed the command with the hash as
* part of building our export table, we need to scan the
* sorted array for matches.
*/
char *subcmdName; /* Name of the subcommand, or unique
* prefix of it (will be an error for
* a non-unique prefix). */
char *fullName = NULL; /* Full name of the subcommand. */
int stringLength, i;
int tableLength = ensemblePtr->subcommandTable.numEntries;
subcmdName = TclGetString(objv[1]);
stringLength = objv[1]->length;
for (i=0 ; i<tableLength ; i++) {
register int cmp = strncmp(subcmdName,
ensemblePtr->subcommandArrayPtr[i],
(unsigned)stringLength);
if (cmp == 0) {
if (fullName != NULL) {
/*
* Since there's never the exact-match case to
* worry about (hash search filters this), getting
* here indicates that our subcommand is an
* ambiguous prefix of (at least) two exported
* subcommands, which is an error case.
*/
goto unknownOrAmbiguousSubcommand;
}
fullName = ensemblePtr->subcommandArrayPtr[i];
} else if (cmp < 0) {
/*
* Because we are searching a sorted table, we can now
* stop searching because we have gone past anything
* that could possibly match.
*/
break;
}
}
if (fullName == NULL) {
/*
* The subcommand is not a prefix of anything, so bail out!
*/
goto unknownOrAmbiguousSubcommand;
}
hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
if (hPtr == NULL) {
Tcl_Panic("full name %s not found in supposedly synchronized hash",
fullName);
}
prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
/*
* Cache for later in the subcommand object.
*/
MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
}
/*
* Do the real work of execution of the subcommand by building an
* array of objects (note that this is potentially not the same
* length as the number of arguments to this ensemble command),
* populating it and then feeding it back through the main
* command-lookup engine. In theory, we could look up the command
* in the namespace ourselves, as we already have the namespace in
* which it is guaranteed to exist, but we don't do that (the
* cacheing of the command object used should help with that.)
*/
Tcl_IncrRefCount(prefixObj);
runResultingSubcommand:
{
Interp *iPtr = (Interp *) interp;
int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
Tcl_ListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv);
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = 2;
iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
} else {
int ni = iPtr->ensembleRewrite.numInsertedObjs;
if (ni < 2) {
iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 1;
} else {
iPtr->ensembleRewrite.numInsertedObjs += prefixObjc - 2;
}
}
tempObjv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *)*(objc-2+prefixObjc));
memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
TCL_EVAL_INVOKE);
Tcl_DecrRefCount(prefixObj);
ckfree((char *)tempObjv);
if (isRootEnsemble) {
iPtr->ensembleRewrite.sourceObjs = NULL;
iPtr->ensembleRewrite.numRemovedObjs = 0;
iPtr->ensembleRewrite.numInsertedObjs = 0;
}
return result;
}
unknownOrAmbiguousSubcommand:
/*
* Have not been able to match the subcommand asked for with a
* real subcommand that we export. See whether a handler has been
* registered for dealing with this situation. Will only call (at
* most) once for any particular ensemble invocation.
*/
if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
int paramc, i;
Tcl_Obj **paramv, *unknownCmd, *ensObj;
unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
TclNewObj(ensObj);
Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
for (i=1 ; i<objc ; i++) {
Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
}
Tcl_ListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv);
Tcl_Preserve(ensemblePtr);
Tcl_IncrRefCount(unknownCmd);
result = Tcl_EvalObjv(interp, paramc, paramv, 0);
if (result == TCL_OK) {
prefixObj = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(prefixObj);
Tcl_DecrRefCount(unknownCmd);
Tcl_Release(ensemblePtr);
Tcl_ResetResult(interp);
if (ensemblePtr->flags & ENS_DEAD) {
Tcl_DecrRefCount(prefixObj);
Tcl_SetResult(interp,
"unknown subcommand handler deleted its ensemble",
TCL_STATIC);
return TCL_ERROR;
}
/*
* Namespace is still there. Check if the result is a
* valid list. If it is, and it is non-empty, that list
* is what we are using as our replacement.
*/
if (Tcl_ListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
Tcl_DecrRefCount(prefixObj);
Tcl_AddErrorInfo(interp,
"\n while parsing result of ensemble unknown subcommand handler");
return TCL_ERROR;
}
if (prefixObjc > 0) {
goto runResultingSubcommand;
}
/*
* Namespace alive & empty result => reparse.
*/
Tcl_DecrRefCount(prefixObj);
goto restartEnsembleParse;
}
if (!Tcl_InterpDeleted(interp)) {
if (result != TCL_ERROR) {
Tcl_ResetResult(interp);
Tcl_SetResult(interp,
"unknown subcommand handler returned bad code: ",
TCL_STATIC);
switch (result) {
case TCL_RETURN:
Tcl_AppendResult(interp, "return", NULL);
break;
case TCL_BREAK:
Tcl_AppendResult(interp, "break", NULL);
break;
case TCL_CONTINUE:
Tcl_AppendResult(interp, "continue", NULL);
break;
default: {
char buf[TCL_INTEGER_SPACE];
sprintf(buf, "%d", result);
Tcl_AppendResult(interp, buf, NULL);
}
}
Tcl_AddErrorInfo(interp,
"\n result of ensemble unknown subcommand handler: ");
Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
} else {
Tcl_AddErrorInfo(interp,
"\n (ensemble unknown subcommand handler)");
}
}
Tcl_DecrRefCount(unknownCmd);
Tcl_Release(ensemblePtr);
return TCL_ERROR;
}
/*
* Cannot determine what subcommand to hand off to, so generate a
* (standard) failure message. Note the one odd case compared
* with standard ensemble-like command, which is where a namespace
* has no exported commands at all...
*/
Tcl_ResetResult(interp);
if (ensemblePtr->subcommandTable.numEntries == 0) {
Tcl_AppendResult(interp, "unknown subcommand \"", TclGetString(objv[1]),
"\": namespace ", ensemblePtr->nsPtr->fullName,
" does not export any commands", NULL);
return TCL_ERROR;
}
Tcl_AppendResult(interp, "unknown ",
(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
"subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
if (ensemblePtr->subcommandTable.numEntries == 1) {
Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
} else {
int i;
for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
Tcl_AppendResult(interp,
ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
}
Tcl_AppendResult(interp, "or ",
ensemblePtr->subcommandArrayPtr[i], NULL);
}
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* MakeCachedEnsembleCommand --
*
* Cache what we've computed so far; it's not nice to repeatedly
* copy strings about. Note that to do this, we start by
* deleting any old representation that there was (though if it
* was an out of date ensemble rep, we can skip some of the
* deallocation process.)
*
* Results:
* None
*
* Side effects:
* Alters the internal representation of the first object parameter.
*
*----------------------------------------------------------------------
*/
static void
MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr)
Tcl_Obj *objPtr;
EnsembleConfig *ensemblePtr;
CONST char *subcommandName;
Tcl_Obj *prefixObjPtr;
{
register EnsembleCmdRep *ensembleCmd;
int length;
if (objPtr->typePtr == &tclEnsembleCmdType) {
ensembleCmd = (EnsembleCmdRep *) objPtr->internalRep.otherValuePtr;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ensembleCmd->nsPtr->refCount--;
if ((ensembleCmd->nsPtr->refCount == 0)
&& (ensembleCmd->nsPtr->flags & NS_DEAD)) {
NamespaceFree(ensembleCmd->nsPtr);
}
ckfree(ensembleCmd->fullSubcmdName);
} else {
/*
* Kill the old internal rep, and replace it with a brand new
* one of our own.
*/
TclFreeIntRep(objPtr);
ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd;
objPtr->typePtr = &tclEnsembleCmdType;
}
/*
* Populate the internal rep.
*/
ensembleCmd->nsPtr = ensemblePtr->nsPtr;
ensembleCmd->epoch = ensemblePtr->epoch;
ensembleCmd->token = ensemblePtr->token;
ensemblePtr->nsPtr->refCount++;
ensembleCmd->realPrefixObj = prefixObjPtr;
length = strlen(subcommandName)+1;
ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
}
/*
*----------------------------------------------------------------------
*
* DeleteEnsembleConfig --
*
* Destroys the data structure used to represent an ensemble.
* This is called when the ensemble's command is deleted (which
* happens automatically if the ensemble's namespace is deleted.)
* Maintainers should note that ensembles should be deleted by
* deleting their commands.
*
* Results:
* None.
*
* Side effects:
* Memory is (eventually) deallocated.
*
*----------------------------------------------------------------------
*/
static void
DeleteEnsembleConfig(clientData)
ClientData clientData;
{
EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
Namespace *nsPtr = ensemblePtr->nsPtr;
Tcl_HashSearch search;
Tcl_HashEntry *hEnt;
/*
* Unlink from the ensemble chain if it has not been marked as
* having been done already.
*/
if (ensemblePtr->next != ensemblePtr) {
EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
if (ensPtr == ensemblePtr) {
nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
} else {
while (ensPtr != NULL) {
if (ensPtr->next == ensemblePtr) {
ensPtr->next = ensemblePtr->next;
break;
}
ensPtr = ensPtr->next;
}
}
}
/*
* Mark the namespace as dead so code that uses Tcl_Preserve() can
* tell whether disaster happened anyway.
*/
ensemblePtr->flags |= ENS_DEAD;
/*
* Kill the pointer-containing fields.
*/
if (ensemblePtr->subcommandTable.numEntries != 0) {
ckfree((char *)ensemblePtr->subcommandArrayPtr);
}
hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
while (hEnt != NULL) {
Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hEnt);
Tcl_DecrRefCount(prefixObj);
hEnt = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
if (ensemblePtr->subcmdList != NULL) {
Tcl_DecrRefCount(ensemblePtr->subcmdList);
}
if (ensemblePtr->subcommandDict != NULL) {
Tcl_DecrRefCount(ensemblePtr->subcommandDict);
}
if (ensemblePtr->unknownHandler != NULL) {
Tcl_DecrRefCount(ensemblePtr->unknownHandler);
}
/*
* Arrange for the structure to be reclaimed. Note that this is
* complex because we have to make sure that we can react sensibly
* when an ensemble is deleted during the process of initialising
* the ensemble (especially the unknown callback.)
*/
Tcl_EventuallyFree((ClientData) ensemblePtr, TCL_DYNAMIC);
}
/*
*----------------------------------------------------------------------
*
* BuildEnsembleConfig --
*
* Create the internal data structures that describe how an
* ensemble looks, being a hash mapping from the full command
* name to the Tcl list that describes the implementation prefix
* words, and a sorted array of all the full command names to
* allow for reasonably efficient unambiguous prefix handling.
*
* Results:
* None.
*
* Side effects:
* Reallocates and rebuilds the hash table and array stored at
* the ensemblePtr argument. For large ensembles or large
* namespaces, this is a potentially expensive operation.
*
*----------------------------------------------------------------------
*/
static void
BuildEnsembleConfig(ensemblePtr)
EnsembleConfig *ensemblePtr;
{
Tcl_HashSearch search; /* Used for scanning the set of
* commands in the namespace that
* backs up this ensemble. */
int i, j, isNew;
Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
Tcl_HashEntry *hPtr;
if (hash->numEntries != 0) {
/*
* Remove pre-existing table.
*/
Tcl_HashSearch search;
ckfree((char *)ensemblePtr->subcommandArrayPtr);
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
Tcl_Obj *prefixObj = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
Tcl_DecrRefCount(prefixObj);
hPtr = Tcl_NextHashEntry(&search);
}
Tcl_DeleteHashTable(hash);
Tcl_InitHashTable(hash, TCL_STRING_KEYS);
}
/*
* See if we've got an export list. If so, we will only export
* exactly those commands, which may be either implemented by the
* prefix in the subcommandDict or mapped directly onto the
* namespace's commands.
*/
if (ensemblePtr->subcmdList != NULL) {
Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
int subcmdc;
Tcl_ListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
&subcmdv);
for (i=0 ; i<subcmdc ; i++) {
char *name = TclGetString(subcmdv[i]);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
/* Skip non-unique cases. */
if (!isNew) {
continue;
}
/*
* Look in our dictionary (if present) for the command.
*/
if (ensemblePtr->subcommandDict != NULL) {
Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
&target);
if (target != NULL) {
Tcl_SetHashValue(hPtr, (ClientData) target);
Tcl_IncrRefCount(target);
continue;
}
}
/*
* Not there, so map onto the namespace. Note in this
* case that we do not guarantee that the command is
* actually there; that is the programmer's responsibility
* (or [::unknown] of course).
*/
cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
if (ensemblePtr->nsPtr->parentPtr != NULL) {
Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
} else {
Tcl_AppendStringsToObj(cmdObj, name, NULL);
}
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
} else if (ensemblePtr->subcommandDict != NULL) {
/*
* No subcmd list, but we do have a mapping dictionary so we
* should use the keys of that. Convert the dictionary's
* contents into the form required for the ensemble's internal
* hashtable.
*/
Tcl_DictSearch dictSearch;
Tcl_Obj *keyObj, *valueObj;
int done;
Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
&keyObj, &valueObj, &done);
while (!done) {
char *name = TclGetString(keyObj);
hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
Tcl_SetHashValue(hPtr, (ClientData) valueObj);
Tcl_IncrRefCount(valueObj);
Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
}
} else {
/*
* Discover what commands are actually exported by the
* namespace. What we have is an array of patterns and a hash
* table whose keys are the command names exported by the
* namespace (the contents do not matter here.) We must find
* out what commands are actually exported by filtering each
* command in the namespace against each of the patterns in
* the export list. Note that we use an intermediate hash
* table to make memory management easier, and because that
* makes exact matching far easier too.
*
* Suggestion for future enhancement: compute the unique
* prefixes and place them in the hash too, which should make
* for even faster matching.
*/
hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
char *nsCmdName = /* Name of command in namespace. */
Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
if (Tcl_StringMatch(nsCmdName,
ensemblePtr->nsPtr->exportArrayPtr[i])) {
hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
/*
* Remember, hash entries have a full reference to
* the substituted part of the command (as a list)
* as their content!
*/
if (isNew) {
Tcl_Obj *cmdObj, *cmdPrefixObj;
TclNewObj(cmdObj);
Tcl_AppendStringsToObj(cmdObj,
ensemblePtr->nsPtr->fullName,
(ensemblePtr->nsPtr->parentPtr ? "::" : ""),
nsCmdName, NULL);
cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
Tcl_SetHashValue(hPtr, (ClientData) cmdPrefixObj);
Tcl_IncrRefCount(cmdPrefixObj);
}
break;
}
}
}
}
if (hash->numEntries == 0) {
ensemblePtr->subcommandArrayPtr = NULL;
return;
}
/*
* Create a sorted array of all subcommands in the ensemble; hash
* tables are all very well for a quick look for an exact match,
* but they can't determine things like whether a string is a
* prefix of another (not without lots of preparation anyway) and
* they're no good for when we're generating the error message
* either.
*
* We do this by filling an array with the names (we use the hash
* keys directly to save a copy, since any time we change the
* array we change the hash too, and vice versa) and running
* quicksort over the array.
*/
ensemblePtr->subcommandArrayPtr = (char **)
ckalloc(sizeof(char *) * hash->numEntries);
/*
* Fill array from both ends as this makes us less likely to end
* up with performance problems in qsort(), which is good. Note
* that doing this makes this code much more opaque, but the naive
* alternatve:
*
* for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
* hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
* ensemblePtr->subcommandArrayPtr[i] =
* Tcl_GetHashKey(hash, &hPtr);
* }
*
* can produce long runs of precisely ordered table entries when
* the commands in the namespace are declared in a sorted fashion
* (an ordering some people like) and the hashing functions (or
* the command names themselves) are fairly unfortunate. By
* filling from both ends, it requires active malice (and probably
* a debugger) to get qsort() to have awful runtime behaviour.
*/
i = 0;
j = hash->numEntries;
hPtr = Tcl_FirstHashEntry(hash, &search);
while (hPtr != NULL) {
ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
if (hPtr == NULL) {
break;
}
ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
hPtr = Tcl_NextHashEntry(&search);
}
if (hash->numEntries > 1) {
qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries,
sizeof(char *), NsEnsembleStringOrder);
}
}
/*
*----------------------------------------------------------------------
*
* NsEnsembleStringOrder --
*
* Helper function to compare two pointers to two strings for use
* with qsort().
*
* Results:
* -1 if the first string is smaller, 1 if the second string is
* smaller, and 0 if they are equal.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
NsEnsembleStringOrder(strPtr1, strPtr2)
CONST VOID *strPtr1, *strPtr2;
{
return strcmp(*(CONST char **)strPtr1, *(CONST char **)strPtr2);
}
/*
*----------------------------------------------------------------------
*
* FreeEnsembleCmdRep --
*
* Destroys the internal representation of a Tcl_Obj that has been
* holding information about a command in an ensemble.
*
* Results:
* None.
*
* Side effects:
* Memory is deallocated. If this held the last reference to a
* namespace's main structure, that main structure will also be
* destroyed.
*
*----------------------------------------------------------------------
*/
static void
FreeEnsembleCmdRep(objPtr)
Tcl_Obj *objPtr;
{
EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
objPtr->internalRep.otherValuePtr;
Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
ckfree(ensembleCmd->fullSubcmdName);
ensembleCmd->nsPtr->refCount--;
if ((ensembleCmd->nsPtr->refCount == 0)
&& (ensembleCmd->nsPtr->flags & NS_DEAD)) {
NamespaceFree(ensembleCmd->nsPtr);
}
ckfree((char *)ensembleCmd);
}
/*
*----------------------------------------------------------------------
*
* DupEnsembleCmdRep --
*
* Makes one Tcl_Obj into a copy of another that is a subcommand
* of an ensemble.
*
* Results:
* None.
*
* Side effects:
* Memory is allocated, and the namespace that the ensemble is
* built on top of gains another reference.
*
*----------------------------------------------------------------------
*/
static void
DupEnsembleCmdRep(objPtr, copyPtr)
Tcl_Obj *objPtr, *copyPtr;
{
EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
objPtr->internalRep.otherValuePtr;
EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
ckalloc(sizeof(EnsembleCmdRep));
int length = strlen(ensembleCmd->fullSubcmdName);
copyPtr->typePtr = &tclEnsembleCmdType;
copyPtr->internalRep.otherValuePtr = (VOID *) ensembleCopy;
ensembleCopy->nsPtr = ensembleCmd->nsPtr;
ensembleCopy->epoch = ensembleCmd->epoch;
ensembleCopy->token = ensembleCmd->token;
ensembleCopy->nsPtr->refCount++;
ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
(unsigned) length+1);
}
/*
*----------------------------------------------------------------------
*
* StringOfEnsembleCmdRep --
*
* Creates a string representation of a Tcl_Obj that holds a
* subcommand of an ensemble.
*
* Results:
* None.
*
* Side effects:
* The object gains a string (UTF-8) representation.
*
*----------------------------------------------------------------------
*/
static void
StringOfEnsembleCmdRep(objPtr)
Tcl_Obj *objPtr;
{
EnsembleCmdRep *ensembleCmd = (EnsembleCmdRep *)
objPtr->internalRep.otherValuePtr;
int length = strlen(ensembleCmd->fullSubcmdName);
objPtr->length = length;
objPtr->bytes = ckalloc((unsigned) length+1);
memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
}