os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclNamesp.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclNamesp.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,4022 @@
1.4 +/*
1.5 + * tclNamesp.c --
1.6 + *
1.7 + * Contains support for namespaces, which provide a separate context of
1.8 + * commands and global variables. The global :: namespace is the
1.9 + * traditional Tcl "global" scope. Other namespaces are created as
1.10 + * children of the global namespace. These other namespaces contain
1.11 + * special-purpose commands and variables for packages.
1.12 + *
1.13 + * Copyright (c) 1993-1997 Lucent Technologies.
1.14 + * Copyright (c) 1997 Sun Microsystems, Inc.
1.15 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.16 + *
1.17 + * Originally implemented by
1.18 + * Michael J. McLennan
1.19 + * Bell Labs Innovations for Lucent Technologies
1.20 + * mmclennan@lucent.com
1.21 + *
1.22 + * See the file "license.terms" for information on usage and redistribution
1.23 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.24 + *
1.25 + * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $
1.26 + */
1.27 +
1.28 +#include "tclInt.h"
1.29 +
1.30 +/*
1.31 + * Flag passed to TclGetNamespaceForQualName to indicate that it should
1.32 + * search for a namespace rather than a command or variable inside a
1.33 + * namespace. Note that this flag's value must not conflict with the values
1.34 + * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN.
1.35 + */
1.36 +
1.37 +#define FIND_ONLY_NS 0x1000
1.38 +
1.39 +/*
1.40 + * Initial size of stack allocated space for tail list - used when resetting
1.41 + * shadowed command references in the functin: TclResetShadowedCmdRefs.
1.42 + */
1.43 +
1.44 +#define NUM_TRAIL_ELEMS 5
1.45 +
1.46 +/*
1.47 + * Count of the number of namespaces created. This value is used as a
1.48 + * unique id for each namespace.
1.49 + */
1.50 +
1.51 +static long numNsCreated = 0;
1.52 +TCL_DECLARE_MUTEX(nsMutex)
1.53 +
1.54 +/*
1.55 + * This structure contains a cached pointer to a namespace that is the
1.56 + * result of resolving the namespace's name in some other namespace. It is
1.57 + * the internal representation for a nsName object. It contains the
1.58 + * pointer along with some information that is used to check the cached
1.59 + * pointer's validity.
1.60 + */
1.61 +
1.62 +typedef struct ResolvedNsName {
1.63 + Namespace *nsPtr; /* A cached namespace pointer. */
1.64 + long nsId; /* nsPtr's unique namespace id. Used to
1.65 + * verify that nsPtr is still valid
1.66 + * (e.g., it's possible that the namespace
1.67 + * was deleted and a new one created at
1.68 + * the same address). */
1.69 + Namespace *refNsPtr; /* Points to the namespace containing the
1.70 + * reference (not the namespace that
1.71 + * contains the referenced namespace). */
1.72 + int refCount; /* Reference count: 1 for each nsName
1.73 + * object that has a pointer to this
1.74 + * ResolvedNsName structure as its internal
1.75 + * rep. This structure can be freed when
1.76 + * refCount becomes zero. */
1.77 +} ResolvedNsName;
1.78 +
1.79 +/*
1.80 + * Declarations for procedures local to this file:
1.81 + */
1.82 +
1.83 +static void DeleteImportedCmd _ANSI_ARGS_((
1.84 + ClientData clientData));
1.85 +static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
1.86 + Tcl_Obj *copyPtr));
1.87 +static void FreeNsNameInternalRep _ANSI_ARGS_((
1.88 + Tcl_Obj *objPtr));
1.89 +static int GetNamespaceFromObj _ANSI_ARGS_((
1.90 + Tcl_Interp *interp, Tcl_Obj *objPtr,
1.91 + Tcl_Namespace **nsPtrPtr));
1.92 +static int InvokeImportedCmd _ANSI_ARGS_((
1.93 + ClientData clientData, Tcl_Interp *interp,
1.94 + int objc, Tcl_Obj *CONST objv[]));
1.95 +static int NamespaceChildrenCmd _ANSI_ARGS_((
1.96 + ClientData dummy, Tcl_Interp *interp,
1.97 + int objc, Tcl_Obj *CONST objv[]));
1.98 +static int NamespaceCodeCmd _ANSI_ARGS_((
1.99 + ClientData dummy, Tcl_Interp *interp,
1.100 + int objc, Tcl_Obj *CONST objv[]));
1.101 +static int NamespaceCurrentCmd _ANSI_ARGS_((
1.102 + ClientData dummy, Tcl_Interp *interp,
1.103 + int objc, Tcl_Obj *CONST objv[]));
1.104 +static int NamespaceDeleteCmd _ANSI_ARGS_((
1.105 + ClientData dummy, Tcl_Interp *interp,
1.106 + int objc, Tcl_Obj *CONST objv[]));
1.107 +static int NamespaceEvalCmd _ANSI_ARGS_((
1.108 + ClientData dummy, Tcl_Interp *interp,
1.109 + int objc, Tcl_Obj *CONST objv[]));
1.110 +static int NamespaceExistsCmd _ANSI_ARGS_((
1.111 + ClientData dummy, Tcl_Interp *interp,
1.112 + int objc, Tcl_Obj *CONST objv[]));
1.113 +static int NamespaceExportCmd _ANSI_ARGS_((
1.114 + ClientData dummy, Tcl_Interp *interp,
1.115 + int objc, Tcl_Obj *CONST objv[]));
1.116 +static int NamespaceForgetCmd _ANSI_ARGS_((
1.117 + ClientData dummy, Tcl_Interp *interp,
1.118 + int objc, Tcl_Obj *CONST objv[]));
1.119 +static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr));
1.120 +static int NamespaceImportCmd _ANSI_ARGS_((
1.121 + ClientData dummy, Tcl_Interp *interp,
1.122 + int objc, Tcl_Obj *CONST objv[]));
1.123 +static int NamespaceInscopeCmd _ANSI_ARGS_((
1.124 + ClientData dummy, Tcl_Interp *interp,
1.125 + int objc, Tcl_Obj *CONST objv[]));
1.126 +static int NamespaceOriginCmd _ANSI_ARGS_((
1.127 + ClientData dummy, Tcl_Interp *interp,
1.128 + int objc, Tcl_Obj *CONST objv[]));
1.129 +static int NamespaceParentCmd _ANSI_ARGS_((
1.130 + ClientData dummy, Tcl_Interp *interp,
1.131 + int objc, Tcl_Obj *CONST objv[]));
1.132 +static int NamespaceQualifiersCmd _ANSI_ARGS_((
1.133 + ClientData dummy, Tcl_Interp *interp,
1.134 + int objc, Tcl_Obj *CONST objv[]));
1.135 +static int NamespaceTailCmd _ANSI_ARGS_((
1.136 + ClientData dummy, Tcl_Interp *interp,
1.137 + int objc, Tcl_Obj *CONST objv[]));
1.138 +static int NamespaceWhichCmd _ANSI_ARGS_((
1.139 + ClientData dummy, Tcl_Interp *interp,
1.140 + int objc, Tcl_Obj *CONST objv[]));
1.141 +static int SetNsNameFromAny _ANSI_ARGS_((
1.142 + Tcl_Interp *interp, Tcl_Obj *objPtr));
1.143 +static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr));
1.144 +
1.145 +/*
1.146 + * This structure defines a Tcl object type that contains a
1.147 + * namespace reference. It is used in commands that take the
1.148 + * name of a namespace as an argument. The namespace reference
1.149 + * is resolved, and the result in cached in the object.
1.150 + */
1.151 +
1.152 +Tcl_ObjType tclNsNameType = {
1.153 + "nsName", /* the type's name */
1.154 + FreeNsNameInternalRep, /* freeIntRepProc */
1.155 + DupNsNameInternalRep, /* dupIntRepProc */
1.156 + UpdateStringOfNsName, /* updateStringProc */
1.157 + SetNsNameFromAny /* setFromAnyProc */
1.158 +};
1.159 +
1.160 +/*
1.161 + *----------------------------------------------------------------------
1.162 + *
1.163 + * TclInitNamespaceSubsystem --
1.164 + *
1.165 + * This procedure is called to initialize all the structures that
1.166 + * are used by namespaces on a per-process basis.
1.167 + *
1.168 + * Results:
1.169 + * None.
1.170 + *
1.171 + * Side effects:
1.172 + * None.
1.173 + *
1.174 + *----------------------------------------------------------------------
1.175 + */
1.176 +
1.177 +void
1.178 +TclInitNamespaceSubsystem()
1.179 +{
1.180 + /*
1.181 + * Does nothing for now.
1.182 + */
1.183 +}
1.184 +
1.185 +/*
1.186 + *----------------------------------------------------------------------
1.187 + *
1.188 + * Tcl_GetCurrentNamespace --
1.189 + *
1.190 + * Returns a pointer to an interpreter's currently active namespace.
1.191 + *
1.192 + * Results:
1.193 + * Returns a pointer to the interpreter's current namespace.
1.194 + *
1.195 + * Side effects:
1.196 + * None.
1.197 + *
1.198 + *----------------------------------------------------------------------
1.199 + */
1.200 +
1.201 +Tcl_Namespace *
1.202 +Tcl_GetCurrentNamespace(interp)
1.203 + register Tcl_Interp *interp; /* Interpreter whose current namespace is
1.204 + * being queried. */
1.205 +{
1.206 + register Interp *iPtr = (Interp *) interp;
1.207 + register Namespace *nsPtr;
1.208 +
1.209 + if (iPtr->varFramePtr != NULL) {
1.210 + nsPtr = iPtr->varFramePtr->nsPtr;
1.211 + } else {
1.212 + nsPtr = iPtr->globalNsPtr;
1.213 + }
1.214 + return (Tcl_Namespace *) nsPtr;
1.215 +}
1.216 +
1.217 +/*
1.218 + *----------------------------------------------------------------------
1.219 + *
1.220 + * Tcl_GetGlobalNamespace --
1.221 + *
1.222 + * Returns a pointer to an interpreter's global :: namespace.
1.223 + *
1.224 + * Results:
1.225 + * Returns a pointer to the specified interpreter's global namespace.
1.226 + *
1.227 + * Side effects:
1.228 + * None.
1.229 + *
1.230 + *----------------------------------------------------------------------
1.231 + */
1.232 +
1.233 +Tcl_Namespace *
1.234 +Tcl_GetGlobalNamespace(interp)
1.235 + register Tcl_Interp *interp; /* Interpreter whose global namespace
1.236 + * should be returned. */
1.237 +{
1.238 + register Interp *iPtr = (Interp *) interp;
1.239 +
1.240 + return (Tcl_Namespace *) iPtr->globalNsPtr;
1.241 +}
1.242 +
1.243 +/*
1.244 + *----------------------------------------------------------------------
1.245 + *
1.246 + * Tcl_PushCallFrame --
1.247 + *
1.248 + * Pushes a new call frame onto the interpreter's Tcl call stack.
1.249 + * Called when executing a Tcl procedure or a "namespace eval" or
1.250 + * "namespace inscope" command.
1.251 + *
1.252 + * Results:
1.253 + * Returns TCL_OK if successful, or TCL_ERROR (along with an error
1.254 + * message in the interpreter's result object) if something goes wrong.
1.255 + *
1.256 + * Side effects:
1.257 + * Modifies the interpreter's Tcl call stack.
1.258 + *
1.259 + *----------------------------------------------------------------------
1.260 + */
1.261 +
1.262 +int
1.263 +Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame)
1.264 + Tcl_Interp *interp; /* Interpreter in which the new call frame
1.265 + * is to be pushed. */
1.266 + Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to
1.267 + * push. Storage for this has already been
1.268 + * allocated by the caller; typically this
1.269 + * is the address of a CallFrame structure
1.270 + * allocated on the caller's C stack. The
1.271 + * call frame will be initialized by this
1.272 + * procedure. The caller can pop the frame
1.273 + * later with Tcl_PopCallFrame, and it is
1.274 + * responsible for freeing the frame's
1.275 + * storage. */
1.276 + Tcl_Namespace *namespacePtr; /* Points to the namespace in which the
1.277 + * frame will execute. If NULL, the
1.278 + * interpreter's current namespace will
1.279 + * be used. */
1.280 + int isProcCallFrame; /* If nonzero, the frame represents a
1.281 + * called Tcl procedure and may have local
1.282 + * vars. Vars will ordinarily be looked up
1.283 + * in the frame. If new variables are
1.284 + * created, they will be created in the
1.285 + * frame. If 0, the frame is for a
1.286 + * "namespace eval" or "namespace inscope"
1.287 + * command and var references are treated
1.288 + * as references to namespace variables. */
1.289 +{
1.290 + Interp *iPtr = (Interp *) interp;
1.291 + register CallFrame *framePtr = (CallFrame *) callFramePtr;
1.292 + register Namespace *nsPtr;
1.293 +
1.294 + if (namespacePtr == NULL) {
1.295 + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.296 + } else {
1.297 + nsPtr = (Namespace *) namespacePtr;
1.298 + if (nsPtr->flags & NS_DEAD) {
1.299 + panic("Trying to push call frame for dead namespace");
1.300 + /*NOTREACHED*/
1.301 + }
1.302 + }
1.303 +
1.304 + nsPtr->activationCount++;
1.305 + framePtr->nsPtr = nsPtr;
1.306 + framePtr->isProcCallFrame = isProcCallFrame;
1.307 + framePtr->objc = 0;
1.308 + framePtr->objv = NULL;
1.309 + framePtr->callerPtr = iPtr->framePtr;
1.310 + framePtr->callerVarPtr = iPtr->varFramePtr;
1.311 + if (iPtr->varFramePtr != NULL) {
1.312 + framePtr->level = (iPtr->varFramePtr->level + 1);
1.313 + } else {
1.314 + framePtr->level = 1;
1.315 + }
1.316 + framePtr->procPtr = NULL; /* no called procedure */
1.317 + framePtr->varTablePtr = NULL; /* and no local variables */
1.318 + framePtr->numCompiledLocals = 0;
1.319 + framePtr->compiledLocals = NULL;
1.320 +
1.321 + /*
1.322 + * Push the new call frame onto the interpreter's stack of procedure
1.323 + * call frames making it the current frame.
1.324 + */
1.325 +
1.326 + iPtr->framePtr = framePtr;
1.327 + iPtr->varFramePtr = framePtr;
1.328 + return TCL_OK;
1.329 +}
1.330 +
1.331 +/*
1.332 + *----------------------------------------------------------------------
1.333 + *
1.334 + * Tcl_PopCallFrame --
1.335 + *
1.336 + * Removes a call frame from the Tcl call stack for the interpreter.
1.337 + * Called to remove a frame previously pushed by Tcl_PushCallFrame.
1.338 + *
1.339 + * Results:
1.340 + * None.
1.341 + *
1.342 + * Side effects:
1.343 + * Modifies the call stack of the interpreter. Resets various fields of
1.344 + * the popped call frame. If a namespace has been deleted and
1.345 + * has no more activations on the call stack, the namespace is
1.346 + * destroyed.
1.347 + *
1.348 + *----------------------------------------------------------------------
1.349 + */
1.350 +
1.351 +void
1.352 +Tcl_PopCallFrame(interp)
1.353 + Tcl_Interp* interp; /* Interpreter with call frame to pop. */
1.354 +{
1.355 + register Interp *iPtr = (Interp *) interp;
1.356 + register CallFrame *framePtr = iPtr->framePtr;
1.357 + Namespace *nsPtr;
1.358 +
1.359 + /*
1.360 + * It's important to remove the call frame from the interpreter's stack
1.361 + * of call frames before deleting local variables, so that traces
1.362 + * invoked by the variable deletion don't see the partially-deleted
1.363 + * frame.
1.364 + */
1.365 +
1.366 + iPtr->framePtr = framePtr->callerPtr;
1.367 + iPtr->varFramePtr = framePtr->callerVarPtr;
1.368 +
1.369 + if (framePtr->varTablePtr != NULL) {
1.370 + TclDeleteVars(iPtr, framePtr->varTablePtr);
1.371 + ckfree((char *) framePtr->varTablePtr);
1.372 + framePtr->varTablePtr = NULL;
1.373 + }
1.374 + if (framePtr->numCompiledLocals > 0) {
1.375 + TclDeleteCompiledLocalVars(iPtr, framePtr);
1.376 + }
1.377 +
1.378 + /*
1.379 + * Decrement the namespace's count of active call frames. If the
1.380 + * namespace is "dying" and there are no more active call frames,
1.381 + * call Tcl_DeleteNamespace to destroy it.
1.382 + */
1.383 +
1.384 + nsPtr = framePtr->nsPtr;
1.385 + nsPtr->activationCount--;
1.386 + if ((nsPtr->flags & NS_DYING)
1.387 + && (nsPtr->activationCount == 0)) {
1.388 + Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
1.389 + }
1.390 + framePtr->nsPtr = NULL;
1.391 +}
1.392 +
1.393 +/*
1.394 + *----------------------------------------------------------------------
1.395 + *
1.396 + * Tcl_CreateNamespace --
1.397 + *
1.398 + * Creates a new namespace with the given name. If there is no
1.399 + * active namespace (i.e., the interpreter is being initialized),
1.400 + * the global :: namespace is created and returned.
1.401 + *
1.402 + * Results:
1.403 + * Returns a pointer to the new namespace if successful. If the
1.404 + * namespace already exists or if another error occurs, this routine
1.405 + * returns NULL, along with an error message in the interpreter's
1.406 + * result object.
1.407 + *
1.408 + * Side effects:
1.409 + * If the name contains "::" qualifiers and a parent namespace does
1.410 + * not already exist, it is automatically created.
1.411 + *
1.412 + *----------------------------------------------------------------------
1.413 + */
1.414 +
1.415 +Tcl_Namespace *
1.416 +Tcl_CreateNamespace(interp, name, clientData, deleteProc)
1.417 + Tcl_Interp *interp; /* Interpreter in which a new namespace
1.418 + * is being created. Also used for
1.419 + * error reporting. */
1.420 + CONST char *name; /* Name for the new namespace. May be a
1.421 + * qualified name with names of ancestor
1.422 + * namespaces separated by "::"s. */
1.423 + ClientData clientData; /* One-word value to store with
1.424 + * namespace. */
1.425 + Tcl_NamespaceDeleteProc *deleteProc;
1.426 + /* Procedure called to delete client
1.427 + * data when the namespace is deleted.
1.428 + * NULL if no procedure should be
1.429 + * called. */
1.430 +{
1.431 + Interp *iPtr = (Interp *) interp;
1.432 + register Namespace *nsPtr, *ancestorPtr;
1.433 + Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
1.434 + Namespace *globalNsPtr = iPtr->globalNsPtr;
1.435 + CONST char *simpleName;
1.436 + Tcl_HashEntry *entryPtr;
1.437 + Tcl_DString buffer1, buffer2;
1.438 + int newEntry;
1.439 +
1.440 + /*
1.441 + * If there is no active namespace, the interpreter is being
1.442 + * initialized.
1.443 + */
1.444 +
1.445 + if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
1.446 + /*
1.447 + * Treat this namespace as the global namespace, and avoid
1.448 + * looking for a parent.
1.449 + */
1.450 +
1.451 + parentPtr = NULL;
1.452 + simpleName = "";
1.453 + } else if (*name == '\0') {
1.454 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.455 + "can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
1.456 + return NULL;
1.457 + } else {
1.458 + /*
1.459 + * Find the parent for the new namespace.
1.460 + */
1.461 +
1.462 + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
1.463 + /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
1.464 + &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
1.465 +
1.466 + /*
1.467 + * If the unqualified name at the end is empty, there were trailing
1.468 + * "::"s after the namespace's name which we ignore. The new
1.469 + * namespace was already (recursively) created and is pointed to
1.470 + * by parentPtr.
1.471 + */
1.472 +
1.473 + if (*simpleName == '\0') {
1.474 + return (Tcl_Namespace *) parentPtr;
1.475 + }
1.476 +
1.477 + /*
1.478 + * Check for a bad namespace name and make sure that the name
1.479 + * does not already exist in the parent namespace.
1.480 + */
1.481 +
1.482 + if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
1.483 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.484 + "can't create namespace \"", name,
1.485 + "\": already exists", (char *) NULL);
1.486 + return NULL;
1.487 + }
1.488 + }
1.489 +
1.490 + /*
1.491 + * Create the new namespace and root it in its parent. Increment the
1.492 + * count of namespaces created.
1.493 + */
1.494 +
1.495 +
1.496 + nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
1.497 + nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
1.498 + strcpy(nsPtr->name, simpleName);
1.499 + nsPtr->fullName = NULL; /* set below */
1.500 + nsPtr->clientData = clientData;
1.501 + nsPtr->deleteProc = deleteProc;
1.502 + nsPtr->parentPtr = parentPtr;
1.503 + Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
1.504 + Tcl_MutexLock(&nsMutex);
1.505 + numNsCreated++;
1.506 + nsPtr->nsId = numNsCreated;
1.507 + Tcl_MutexUnlock(&nsMutex);
1.508 + nsPtr->interp = interp;
1.509 + nsPtr->flags = 0;
1.510 + nsPtr->activationCount = 0;
1.511 + nsPtr->refCount = 0;
1.512 + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
1.513 + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
1.514 + nsPtr->exportArrayPtr = NULL;
1.515 + nsPtr->numExportPatterns = 0;
1.516 + nsPtr->maxExportPatterns = 0;
1.517 + nsPtr->cmdRefEpoch = 0;
1.518 + nsPtr->resolverEpoch = 0;
1.519 + nsPtr->cmdResProc = NULL;
1.520 + nsPtr->varResProc = NULL;
1.521 + nsPtr->compiledVarResProc = NULL;
1.522 +
1.523 + if (parentPtr != NULL) {
1.524 + entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
1.525 + &newEntry);
1.526 + Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
1.527 + }
1.528 +
1.529 + /*
1.530 + * Build the fully qualified name for this namespace.
1.531 + */
1.532 +
1.533 + Tcl_DStringInit(&buffer1);
1.534 + Tcl_DStringInit(&buffer2);
1.535 + for (ancestorPtr = nsPtr; ancestorPtr != NULL;
1.536 + ancestorPtr = ancestorPtr->parentPtr) {
1.537 + if (ancestorPtr != globalNsPtr) {
1.538 + Tcl_DStringAppend(&buffer1, "::", 2);
1.539 + Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1);
1.540 + }
1.541 + Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1);
1.542 +
1.543 + Tcl_DStringSetLength(&buffer2, 0);
1.544 + Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1);
1.545 + Tcl_DStringSetLength(&buffer1, 0);
1.546 + }
1.547 +
1.548 + name = Tcl_DStringValue(&buffer2);
1.549 + nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1));
1.550 + strcpy(nsPtr->fullName, name);
1.551 +
1.552 + Tcl_DStringFree(&buffer1);
1.553 + Tcl_DStringFree(&buffer2);
1.554 +
1.555 + /*
1.556 + * Return a pointer to the new namespace.
1.557 + */
1.558 +
1.559 + return (Tcl_Namespace *) nsPtr;
1.560 +}
1.561 +
1.562 +/*
1.563 + *----------------------------------------------------------------------
1.564 + *
1.565 + * Tcl_DeleteNamespace --
1.566 + *
1.567 + * Deletes a namespace and all of the commands, variables, and other
1.568 + * namespaces within it.
1.569 + *
1.570 + * Results:
1.571 + * None.
1.572 + *
1.573 + * Side effects:
1.574 + * When a namespace is deleted, it is automatically removed as a
1.575 + * child of its parent namespace. Also, all its commands, variables
1.576 + * and child namespaces are deleted.
1.577 + *
1.578 + *----------------------------------------------------------------------
1.579 + */
1.580 +
1.581 +void
1.582 +Tcl_DeleteNamespace(namespacePtr)
1.583 + Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */
1.584 +{
1.585 + register Namespace *nsPtr = (Namespace *) namespacePtr;
1.586 + Interp *iPtr = (Interp *) nsPtr->interp;
1.587 + Namespace *globalNsPtr =
1.588 + (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
1.589 + Tcl_HashEntry *entryPtr;
1.590 +
1.591 + /*
1.592 + * If the namespace is on the call frame stack, it is marked as "dying"
1.593 + * (NS_DYING is OR'd into its flags): the namespace can't be looked up
1.594 + * by name but its commands and variables are still usable by those
1.595 + * active call frames. When all active call frames referring to the
1.596 + * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will
1.597 + * call this procedure again to delete everything in the namespace.
1.598 + * If no nsName objects refer to the namespace (i.e., if its refCount
1.599 + * is zero), its commands and variables are deleted and the storage for
1.600 + * its namespace structure is freed. Otherwise, if its refCount is
1.601 + * nonzero, the namespace's commands and variables are deleted but the
1.602 + * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's
1.603 + * flags to allow the namespace resolution code to recognize that the
1.604 + * namespace is "deleted". The structure's storage is freed by
1.605 + * FreeNsNameInternalRep when its refCount reaches 0.
1.606 + */
1.607 +
1.608 + if (nsPtr->activationCount > 0) {
1.609 + nsPtr->flags |= NS_DYING;
1.610 + if (nsPtr->parentPtr != NULL) {
1.611 + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
1.612 + nsPtr->name);
1.613 + if (entryPtr != NULL) {
1.614 + Tcl_DeleteHashEntry(entryPtr);
1.615 + }
1.616 + }
1.617 + nsPtr->parentPtr = NULL;
1.618 + } else if (!(nsPtr->flags & NS_KILLED)) {
1.619 + /*
1.620 + * Delete the namespace and everything in it. If this is the global
1.621 + * namespace, then clear it but don't free its storage unless the
1.622 + * interpreter is being torn down. Set the NS_KILLED flag to avoid
1.623 + * recursive calls here - if the namespace is really in the process of
1.624 + * being deleted, ignore any second call.
1.625 + */
1.626 +
1.627 + nsPtr->flags |= (NS_DYING|NS_KILLED);
1.628 +
1.629 + TclTeardownNamespace(nsPtr);
1.630 +
1.631 + if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
1.632 + /*
1.633 + * If this is the global namespace, then it may have residual
1.634 + * "errorInfo" and "errorCode" variables for errors that
1.635 + * occurred while it was being torn down. Try to clear the
1.636 + * variable list one last time.
1.637 + */
1.638 +
1.639 + TclDeleteNamespaceVars(nsPtr);
1.640 +
1.641 + Tcl_DeleteHashTable(&nsPtr->childTable);
1.642 + Tcl_DeleteHashTable(&nsPtr->cmdTable);
1.643 +
1.644 + /*
1.645 + * If the reference count is 0, then discard the namespace.
1.646 + * Otherwise, mark it as "dead" so that it can't be used.
1.647 + */
1.648 +
1.649 + if (nsPtr->refCount == 0) {
1.650 + NamespaceFree(nsPtr);
1.651 + } else {
1.652 + nsPtr->flags |= NS_DEAD;
1.653 + }
1.654 + } else {
1.655 + /*
1.656 + * We didn't really kill it, so remove the KILLED marks, so
1.657 + * it can get killed later, avoiding mem leaks
1.658 + */
1.659 + nsPtr->flags &= ~(NS_DYING|NS_KILLED);
1.660 + }
1.661 + }
1.662 +}
1.663 +
1.664 +/*
1.665 + *----------------------------------------------------------------------
1.666 + *
1.667 + * TclTeardownNamespace --
1.668 + *
1.669 + * Used internally to dismantle and unlink a namespace when it is
1.670 + * deleted. Divorces the namespace from its parent, and deletes all
1.671 + * commands, variables, and child namespaces.
1.672 + *
1.673 + * This is kept separate from Tcl_DeleteNamespace so that the global
1.674 + * namespace can be handled specially. Global variables like
1.675 + * "errorInfo" and "errorCode" need to remain intact while other
1.676 + * namespaces and commands are torn down, in case any errors occur.
1.677 + *
1.678 + * Results:
1.679 + * None.
1.680 + *
1.681 + * Side effects:
1.682 + * Removes this namespace from its parent's child namespace hashtable.
1.683 + * Deletes all commands, variables and namespaces in this namespace.
1.684 + * If this is the global namespace, the "errorInfo" and "errorCode"
1.685 + * variables are left alone and deleted later.
1.686 + *
1.687 + *----------------------------------------------------------------------
1.688 + */
1.689 +
1.690 +void
1.691 +TclTeardownNamespace(nsPtr)
1.692 + register Namespace *nsPtr; /* Points to the namespace to be dismantled
1.693 + * and unlinked from its parent. */
1.694 +{
1.695 + Interp *iPtr = (Interp *) nsPtr->interp;
1.696 + register Tcl_HashEntry *entryPtr;
1.697 + Tcl_HashSearch search;
1.698 + Tcl_Namespace *childNsPtr;
1.699 + Tcl_Command cmd;
1.700 + Namespace *globalNsPtr =
1.701 + (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr);
1.702 + int i;
1.703 +
1.704 + /*
1.705 + * Start by destroying the namespace's variable table,
1.706 + * since variables might trigger traces.
1.707 + */
1.708 +
1.709 + if (nsPtr == globalNsPtr) {
1.710 + /*
1.711 + * This is the global namespace. Tearing it down will destroy the
1.712 + * ::errorInfo and ::errorCode variables. We save and restore them
1.713 + * in case there are any errors in progress, so the error details
1.714 + * they contain will not be lost. See test namespace-8.5
1.715 + */
1.716 +
1.717 + Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo",
1.718 + NULL, TCL_GLOBAL_ONLY);
1.719 + Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode",
1.720 + NULL, TCL_GLOBAL_ONLY);
1.721 +
1.722 + if (errorInfo) {
1.723 + Tcl_IncrRefCount(errorInfo);
1.724 + }
1.725 + if (errorCode) {
1.726 + Tcl_IncrRefCount(errorCode);
1.727 + }
1.728 +
1.729 + TclDeleteNamespaceVars(nsPtr);
1.730 + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
1.731 +
1.732 + if (errorInfo) {
1.733 + Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL,
1.734 + errorInfo, TCL_GLOBAL_ONLY);
1.735 + Tcl_DecrRefCount(errorInfo);
1.736 + }
1.737 + if (errorCode) {
1.738 + Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL,
1.739 + errorCode, TCL_GLOBAL_ONLY);
1.740 + Tcl_DecrRefCount(errorCode);
1.741 + }
1.742 + } else {
1.743 + /*
1.744 + * Variable table should be cleared but not freed! TclDeleteVars
1.745 + * frees it, so we reinitialize it afterwards.
1.746 + */
1.747 +
1.748 + TclDeleteNamespaceVars(nsPtr);
1.749 + Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS);
1.750 + }
1.751 +
1.752 + /*
1.753 + * Delete all commands in this namespace. Be careful when traversing the
1.754 + * hash table: when each command is deleted, it removes itself from the
1.755 + * command table.
1.756 + */
1.757 +
1.758 + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1.759 + entryPtr != NULL;
1.760 + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
1.761 + cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr);
1.762 + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
1.763 + }
1.764 + Tcl_DeleteHashTable(&nsPtr->cmdTable);
1.765 + Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
1.766 +
1.767 + /*
1.768 + * Remove the namespace from its parent's child hashtable.
1.769 + */
1.770 +
1.771 + if (nsPtr->parentPtr != NULL) {
1.772 + entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
1.773 + nsPtr->name);
1.774 + if (entryPtr != NULL) {
1.775 + Tcl_DeleteHashEntry(entryPtr);
1.776 + }
1.777 + }
1.778 + nsPtr->parentPtr = NULL;
1.779 +
1.780 + /*
1.781 + * Delete all the child namespaces.
1.782 + *
1.783 + * BE CAREFUL: When each child is deleted, it will divorce
1.784 + * itself from its parent. You can't traverse a hash table
1.785 + * properly if its elements are being deleted. We use only
1.786 + * the Tcl_FirstHashEntry function to be safe.
1.787 + */
1.788 +
1.789 + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
1.790 + entryPtr != NULL;
1.791 + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
1.792 + childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr);
1.793 + Tcl_DeleteNamespace(childNsPtr);
1.794 + }
1.795 +
1.796 + /*
1.797 + * Free the namespace's export pattern array.
1.798 + */
1.799 +
1.800 + if (nsPtr->exportArrayPtr != NULL) {
1.801 + for (i = 0; i < nsPtr->numExportPatterns; i++) {
1.802 + ckfree(nsPtr->exportArrayPtr[i]);
1.803 + }
1.804 + ckfree((char *) nsPtr->exportArrayPtr);
1.805 + nsPtr->exportArrayPtr = NULL;
1.806 + nsPtr->numExportPatterns = 0;
1.807 + nsPtr->maxExportPatterns = 0;
1.808 + }
1.809 +
1.810 + /*
1.811 + * Free any client data associated with the namespace.
1.812 + */
1.813 +
1.814 + if (nsPtr->deleteProc != NULL) {
1.815 + (*nsPtr->deleteProc)(nsPtr->clientData);
1.816 + }
1.817 + nsPtr->deleteProc = NULL;
1.818 + nsPtr->clientData = NULL;
1.819 +
1.820 + /*
1.821 + * Reset the namespace's id field to ensure that this namespace won't
1.822 + * be interpreted as valid by, e.g., the cache validation code for
1.823 + * cached command references in Tcl_GetCommandFromObj.
1.824 + */
1.825 +
1.826 + nsPtr->nsId = 0;
1.827 +}
1.828 +
1.829 +/*
1.830 + *----------------------------------------------------------------------
1.831 + *
1.832 + * NamespaceFree --
1.833 + *
1.834 + * Called after a namespace has been deleted, when its
1.835 + * reference count reaches 0. Frees the data structure
1.836 + * representing the namespace.
1.837 + *
1.838 + * Results:
1.839 + * None.
1.840 + *
1.841 + * Side effects:
1.842 + * None.
1.843 + *
1.844 + *----------------------------------------------------------------------
1.845 + */
1.846 +
1.847 +static void
1.848 +NamespaceFree(nsPtr)
1.849 + register Namespace *nsPtr; /* Points to the namespace to free. */
1.850 +{
1.851 + /*
1.852 + * Most of the namespace's contents are freed when the namespace is
1.853 + * deleted by Tcl_DeleteNamespace. All that remains is to free its names
1.854 + * (for error messages), and the structure itself.
1.855 + */
1.856 +
1.857 + ckfree(nsPtr->name);
1.858 + ckfree(nsPtr->fullName);
1.859 +
1.860 + ckfree((char *) nsPtr);
1.861 +}
1.862 +
1.863 +
1.864 +/*
1.865 + *----------------------------------------------------------------------
1.866 + *
1.867 + * Tcl_Export --
1.868 + *
1.869 + * Makes all the commands matching a pattern available to later be
1.870 + * imported from the namespace specified by namespacePtr (or the
1.871 + * current namespace if namespacePtr is NULL). The specified pattern is
1.872 + * appended onto the namespace's export pattern list, which is
1.873 + * optionally cleared beforehand.
1.874 + *
1.875 + * Results:
1.876 + * Returns TCL_OK if successful, or TCL_ERROR (along with an error
1.877 + * message in the interpreter's result) if something goes wrong.
1.878 + *
1.879 + * Side effects:
1.880 + * Appends the export pattern onto the namespace's export list.
1.881 + * Optionally reset the namespace's export pattern list.
1.882 + *
1.883 + *----------------------------------------------------------------------
1.884 + */
1.885 +
1.886 +int
1.887 +Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
1.888 + Tcl_Interp *interp; /* Current interpreter. */
1.889 + Tcl_Namespace *namespacePtr; /* Points to the namespace from which
1.890 + * commands are to be exported. NULL for
1.891 + * the current namespace. */
1.892 + CONST char *pattern; /* String pattern indicating which commands
1.893 + * to export. This pattern may not include
1.894 + * any namespace qualifiers; only commands
1.895 + * in the specified namespace may be
1.896 + * exported. */
1.897 + int resetListFirst; /* If nonzero, resets the namespace's
1.898 + * export list before appending. */
1.899 +{
1.900 +#define INIT_EXPORT_PATTERNS 5
1.901 + Namespace *nsPtr, *exportNsPtr, *dummyPtr;
1.902 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.903 + CONST char *simplePattern;
1.904 + char *patternCpy;
1.905 + int neededElems, len, i;
1.906 +
1.907 + /*
1.908 + * If the specified namespace is NULL, use the current namespace.
1.909 + */
1.910 +
1.911 + if (namespacePtr == NULL) {
1.912 + nsPtr = (Namespace *) currNsPtr;
1.913 + } else {
1.914 + nsPtr = (Namespace *) namespacePtr;
1.915 + }
1.916 +
1.917 + /*
1.918 + * If resetListFirst is true (nonzero), clear the namespace's export
1.919 + * pattern list.
1.920 + */
1.921 +
1.922 + if (resetListFirst) {
1.923 + if (nsPtr->exportArrayPtr != NULL) {
1.924 + for (i = 0; i < nsPtr->numExportPatterns; i++) {
1.925 + ckfree(nsPtr->exportArrayPtr[i]);
1.926 + }
1.927 + ckfree((char *) nsPtr->exportArrayPtr);
1.928 + nsPtr->exportArrayPtr = NULL;
1.929 + nsPtr->numExportPatterns = 0;
1.930 + nsPtr->maxExportPatterns = 0;
1.931 + }
1.932 + }
1.933 +
1.934 + /*
1.935 + * Check that the pattern doesn't have namespace qualifiers.
1.936 + */
1.937 +
1.938 + TclGetNamespaceForQualName(interp, pattern, nsPtr,
1.939 + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
1.940 + &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1.941 +
1.942 + if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
1.943 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.944 + "invalid export pattern \"", pattern,
1.945 + "\": pattern can't specify a namespace",
1.946 + (char *) NULL);
1.947 + return TCL_ERROR;
1.948 + }
1.949 +
1.950 + /*
1.951 + * Make sure that we don't already have the pattern in the array
1.952 + */
1.953 + if (nsPtr->exportArrayPtr != NULL) {
1.954 + for (i = 0; i < nsPtr->numExportPatterns; i++) {
1.955 + if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
1.956 + /*
1.957 + * The pattern already exists in the list
1.958 + */
1.959 + return TCL_OK;
1.960 + }
1.961 + }
1.962 + }
1.963 +
1.964 + /*
1.965 + * Make sure there is room in the namespace's pattern array for the
1.966 + * new pattern.
1.967 + */
1.968 +
1.969 + neededElems = nsPtr->numExportPatterns + 1;
1.970 + if (nsPtr->exportArrayPtr == NULL) {
1.971 + nsPtr->exportArrayPtr = (char **)
1.972 + ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
1.973 + nsPtr->numExportPatterns = 0;
1.974 + nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
1.975 + } else if (neededElems > nsPtr->maxExportPatterns) {
1.976 + int numNewElems = 2 * nsPtr->maxExportPatterns;
1.977 + size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
1.978 + size_t newBytes = numNewElems * sizeof(char *);
1.979 + char **newPtr = (char **) ckalloc((unsigned) newBytes);
1.980 +
1.981 + memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr,
1.982 + currBytes);
1.983 + ckfree((char *) nsPtr->exportArrayPtr);
1.984 + nsPtr->exportArrayPtr = (char **) newPtr;
1.985 + nsPtr->maxExportPatterns = numNewElems;
1.986 + }
1.987 +
1.988 + /*
1.989 + * Add the pattern to the namespace's array of export patterns.
1.990 + */
1.991 +
1.992 + len = strlen(pattern);
1.993 + patternCpy = (char *) ckalloc((unsigned) (len + 1));
1.994 + strcpy(patternCpy, pattern);
1.995 +
1.996 + nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
1.997 + nsPtr->numExportPatterns++;
1.998 + return TCL_OK;
1.999 +#undef INIT_EXPORT_PATTERNS
1.1000 +}
1.1001 +
1.1002 +/*
1.1003 + *----------------------------------------------------------------------
1.1004 + *
1.1005 + * Tcl_AppendExportList --
1.1006 + *
1.1007 + * Appends onto the argument object the list of export patterns for the
1.1008 + * specified namespace.
1.1009 + *
1.1010 + * Results:
1.1011 + * The return value is normally TCL_OK; in this case the object
1.1012 + * referenced by objPtr has each export pattern appended to it. If an
1.1013 + * error occurs, TCL_ERROR is returned and the interpreter's result
1.1014 + * holds an error message.
1.1015 + *
1.1016 + * Side effects:
1.1017 + * If necessary, the object referenced by objPtr is converted into
1.1018 + * a list object.
1.1019 + *
1.1020 + *----------------------------------------------------------------------
1.1021 + */
1.1022 +
1.1023 +int
1.1024 +Tcl_AppendExportList(interp, namespacePtr, objPtr)
1.1025 + Tcl_Interp *interp; /* Interpreter used for error reporting. */
1.1026 + Tcl_Namespace *namespacePtr; /* Points to the namespace whose export
1.1027 + * pattern list is appended onto objPtr.
1.1028 + * NULL for the current namespace. */
1.1029 + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the
1.1030 + * export pattern list is appended. */
1.1031 +{
1.1032 + Namespace *nsPtr;
1.1033 + int i, result;
1.1034 +
1.1035 + /*
1.1036 + * If the specified namespace is NULL, use the current namespace.
1.1037 + */
1.1038 +
1.1039 + if (namespacePtr == NULL) {
1.1040 + nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp);
1.1041 + } else {
1.1042 + nsPtr = (Namespace *) namespacePtr;
1.1043 + }
1.1044 +
1.1045 + /*
1.1046 + * Append the export pattern list onto objPtr.
1.1047 + */
1.1048 +
1.1049 + for (i = 0; i < nsPtr->numExportPatterns; i++) {
1.1050 + result = Tcl_ListObjAppendElement(interp, objPtr,
1.1051 + Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
1.1052 + if (result != TCL_OK) {
1.1053 + return result;
1.1054 + }
1.1055 + }
1.1056 + return TCL_OK;
1.1057 +}
1.1058 +
1.1059 +/*
1.1060 + *----------------------------------------------------------------------
1.1061 + *
1.1062 + * Tcl_Import --
1.1063 + *
1.1064 + * Imports all of the commands matching a pattern into the namespace
1.1065 + * specified by namespacePtr (or the current namespace if contextNsPtr
1.1066 + * is NULL). This is done by creating a new command (the "imported
1.1067 + * command") that points to the real command in its original namespace.
1.1068 + *
1.1069 + * If matching commands are on the autoload path but haven't been
1.1070 + * loaded yet, this command forces them to be loaded, then creates
1.1071 + * the links to them.
1.1072 + *
1.1073 + * Results:
1.1074 + * Returns TCL_OK if successful, or TCL_ERROR (along with an error
1.1075 + * message in the interpreter's result) if something goes wrong.
1.1076 + *
1.1077 + * Side effects:
1.1078 + * Creates new commands in the importing namespace. These indirect
1.1079 + * calls back to the real command and are deleted if the real commands
1.1080 + * are deleted.
1.1081 + *
1.1082 + *----------------------------------------------------------------------
1.1083 + */
1.1084 +
1.1085 +int
1.1086 +Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
1.1087 + Tcl_Interp *interp; /* Current interpreter. */
1.1088 + Tcl_Namespace *namespacePtr; /* Points to the namespace into which the
1.1089 + * commands are to be imported. NULL for
1.1090 + * the current namespace. */
1.1091 + CONST char *pattern; /* String pattern indicating which commands
1.1092 + * to import. This pattern should be
1.1093 + * qualified by the name of the namespace
1.1094 + * from which to import the command(s). */
1.1095 + int allowOverwrite; /* If nonzero, allow existing commands to
1.1096 + * be overwritten by imported commands.
1.1097 + * If 0, return an error if an imported
1.1098 + * cmd conflicts with an existing one. */
1.1099 +{
1.1100 + Interp *iPtr = (Interp *) interp;
1.1101 + Namespace *nsPtr, *importNsPtr, *dummyPtr;
1.1102 + Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.1103 + CONST char *simplePattern;
1.1104 + char *cmdName;
1.1105 + register Tcl_HashEntry *hPtr;
1.1106 + Tcl_HashSearch search;
1.1107 + Command *cmdPtr;
1.1108 + ImportRef *refPtr;
1.1109 + Tcl_Command autoCmd, importedCmd;
1.1110 + ImportedCmdData *dataPtr;
1.1111 + int wasExported, i, result;
1.1112 +
1.1113 + /*
1.1114 + * If the specified namespace is NULL, use the current namespace.
1.1115 + */
1.1116 +
1.1117 + if (namespacePtr == NULL) {
1.1118 + nsPtr = (Namespace *) currNsPtr;
1.1119 + } else {
1.1120 + nsPtr = (Namespace *) namespacePtr;
1.1121 + }
1.1122 +
1.1123 + /*
1.1124 + * First, invoke the "auto_import" command with the pattern
1.1125 + * being imported. This command is part of the Tcl library.
1.1126 + * It looks for imported commands in autoloaded libraries and
1.1127 + * loads them in. That way, they will be found when we try
1.1128 + * to create links below.
1.1129 + */
1.1130 +
1.1131 + autoCmd = Tcl_FindCommand(interp, "auto_import",
1.1132 + (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
1.1133 +
1.1134 + if (autoCmd != NULL) {
1.1135 + Tcl_Obj *objv[2];
1.1136 +
1.1137 + objv[0] = Tcl_NewStringObj("auto_import", -1);
1.1138 + Tcl_IncrRefCount(objv[0]);
1.1139 + objv[1] = Tcl_NewStringObj(pattern, -1);
1.1140 + Tcl_IncrRefCount(objv[1]);
1.1141 +
1.1142 + cmdPtr = (Command *) autoCmd;
1.1143 + result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
1.1144 + 2, objv);
1.1145 +
1.1146 + Tcl_DecrRefCount(objv[0]);
1.1147 + Tcl_DecrRefCount(objv[1]);
1.1148 +
1.1149 + if (result != TCL_OK) {
1.1150 + return TCL_ERROR;
1.1151 + }
1.1152 + Tcl_ResetResult(interp);
1.1153 + }
1.1154 +
1.1155 + /*
1.1156 + * From the pattern, find the namespace from which we are importing
1.1157 + * and get the simple pattern (no namespace qualifiers or ::'s) at
1.1158 + * the end.
1.1159 + */
1.1160 +
1.1161 + if (strlen(pattern) == 0) {
1.1162 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.1163 + "empty import pattern", -1);
1.1164 + return TCL_ERROR;
1.1165 + }
1.1166 + TclGetNamespaceForQualName(interp, pattern, nsPtr,
1.1167 + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
1.1168 + &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1.1169 +
1.1170 + if (importNsPtr == NULL) {
1.1171 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1172 + "unknown namespace in import pattern \"",
1.1173 + pattern, "\"", (char *) NULL);
1.1174 + return TCL_ERROR;
1.1175 + }
1.1176 + if (importNsPtr == nsPtr) {
1.1177 + if (pattern == simplePattern) {
1.1178 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1179 + "no namespace specified in import pattern \"", pattern,
1.1180 + "\"", (char *) NULL);
1.1181 + } else {
1.1182 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1183 + "import pattern \"", pattern,
1.1184 + "\" tries to import from namespace \"",
1.1185 + importNsPtr->name, "\" into itself", (char *) NULL);
1.1186 + }
1.1187 + return TCL_ERROR;
1.1188 + }
1.1189 +
1.1190 + /*
1.1191 + * Scan through the command table in the source namespace and look for
1.1192 + * exported commands that match the string pattern. Create an "imported
1.1193 + * command" in the current namespace for each imported command; these
1.1194 + * commands redirect their invocations to the "real" command.
1.1195 + */
1.1196 +
1.1197 + for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
1.1198 + (hPtr != NULL);
1.1199 + hPtr = Tcl_NextHashEntry(&search)) {
1.1200 + cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
1.1201 + if (Tcl_StringMatch(cmdName, simplePattern)) {
1.1202 + /*
1.1203 + * The command cmdName in the source namespace matches the
1.1204 + * pattern. Check whether it was exported. If it wasn't,
1.1205 + * we ignore it.
1.1206 + */
1.1207 + Tcl_HashEntry *found;
1.1208 +
1.1209 + wasExported = 0;
1.1210 + for (i = 0; i < importNsPtr->numExportPatterns; i++) {
1.1211 + if (Tcl_StringMatch(cmdName,
1.1212 + importNsPtr->exportArrayPtr[i])) {
1.1213 + wasExported = 1;
1.1214 + break;
1.1215 + }
1.1216 + }
1.1217 + if (!wasExported) {
1.1218 + continue;
1.1219 + }
1.1220 +
1.1221 + /*
1.1222 + * Unless there is a name clash, create an imported command
1.1223 + * in the current namespace that refers to cmdPtr.
1.1224 + */
1.1225 +
1.1226 + found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
1.1227 + if ((found == NULL) || allowOverwrite) {
1.1228 + /*
1.1229 + * Create the imported command and its client data.
1.1230 + * To create the new command in the current namespace,
1.1231 + * generate a fully qualified name for it.
1.1232 + */
1.1233 +
1.1234 + Tcl_DString ds;
1.1235 +
1.1236 + Tcl_DStringInit(&ds);
1.1237 + Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
1.1238 + if (nsPtr != iPtr->globalNsPtr) {
1.1239 + Tcl_DStringAppend(&ds, "::", 2);
1.1240 + }
1.1241 + Tcl_DStringAppend(&ds, cmdName, -1);
1.1242 +
1.1243 + /*
1.1244 + * Check whether creating the new imported command in the
1.1245 + * current namespace would create a cycle of imported
1.1246 + * command references.
1.1247 + */
1.1248 +
1.1249 + cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.1250 + if ((found != NULL)
1.1251 + && cmdPtr->deleteProc == DeleteImportedCmd) {
1.1252 +
1.1253 + Command *overwrite = (Command *) Tcl_GetHashValue(found);
1.1254 + Command *link = cmdPtr;
1.1255 + while (link->deleteProc == DeleteImportedCmd) {
1.1256 + ImportedCmdData *dataPtr;
1.1257 +
1.1258 + dataPtr = (ImportedCmdData *) link->objClientData;
1.1259 + link = dataPtr->realCmdPtr;
1.1260 + if (overwrite == link) {
1.1261 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1262 + "import pattern \"", pattern,
1.1263 + "\" would create a loop containing ",
1.1264 + "command \"", Tcl_DStringValue(&ds),
1.1265 + "\"", (char *) NULL);
1.1266 + Tcl_DStringFree(&ds);
1.1267 + return TCL_ERROR;
1.1268 + }
1.1269 + }
1.1270 + }
1.1271 +
1.1272 + dataPtr = (ImportedCmdData *)
1.1273 + ckalloc(sizeof(ImportedCmdData));
1.1274 + importedCmd = Tcl_CreateObjCommand(interp,
1.1275 + Tcl_DStringValue(&ds), InvokeImportedCmd,
1.1276 + (ClientData) dataPtr, DeleteImportedCmd);
1.1277 + dataPtr->realCmdPtr = cmdPtr;
1.1278 + dataPtr->selfPtr = (Command *) importedCmd;
1.1279 + dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
1.1280 + Tcl_DStringFree(&ds);
1.1281 +
1.1282 + /*
1.1283 + * Create an ImportRef structure describing this new import
1.1284 + * command and add it to the import ref list in the "real"
1.1285 + * command.
1.1286 + */
1.1287 +
1.1288 + refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
1.1289 + refPtr->importedCmdPtr = (Command *) importedCmd;
1.1290 + refPtr->nextPtr = cmdPtr->importRefPtr;
1.1291 + cmdPtr->importRefPtr = refPtr;
1.1292 + } else {
1.1293 + Command *overwrite = (Command *) Tcl_GetHashValue(found);
1.1294 + if (overwrite->deleteProc == DeleteImportedCmd) {
1.1295 + ImportedCmdData *dataPtr =
1.1296 + (ImportedCmdData *) overwrite->objClientData;
1.1297 + if (dataPtr->realCmdPtr
1.1298 + == (Command *) Tcl_GetHashValue(hPtr)) {
1.1299 + /* Repeated import of same command -- acceptable */
1.1300 + return TCL_OK;
1.1301 + }
1.1302 + }
1.1303 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1304 + "can't import command \"", cmdName,
1.1305 + "\": already exists", (char *) NULL);
1.1306 + return TCL_ERROR;
1.1307 + }
1.1308 + }
1.1309 + }
1.1310 + return TCL_OK;
1.1311 +}
1.1312 +
1.1313 +/*
1.1314 + *----------------------------------------------------------------------
1.1315 + *
1.1316 + * Tcl_ForgetImport --
1.1317 + *
1.1318 + * Deletes commands previously imported into the namespace indicated. The
1.1319 + * by namespacePtr, or the current namespace of interp, when
1.1320 + * namespacePtr is NULL. The pattern controls which imported commands
1.1321 + * are deleted. A simple pattern, one without namespace separators,
1.1322 + * matches the current command names of imported commands in the
1.1323 + * namespace. Matching imported commands are deleted. A qualified
1.1324 + * pattern is interpreted as deletion selection on the basis of where
1.1325 + * the command is imported from. The original command and "first link"
1.1326 + * command for each imported command are determined, and they are matched
1.1327 + * against the pattern. A match leads to deletion of the imported
1.1328 + * command.
1.1329 + *
1.1330 + * Results:
1.1331 + * Returns TCL_ERROR and records an error message in the interp
1.1332 + * result if a namespace qualified pattern refers to a namespace
1.1333 + * that does not exist. Otherwise, returns TCL_OK.
1.1334 + *
1.1335 + * Side effects:
1.1336 + * May delete commands.
1.1337 + *
1.1338 + *----------------------------------------------------------------------
1.1339 + */
1.1340 +
1.1341 +int
1.1342 +Tcl_ForgetImport(interp, namespacePtr, pattern)
1.1343 + Tcl_Interp *interp; /* Current interpreter. */
1.1344 + Tcl_Namespace *namespacePtr; /* Points to the namespace from which
1.1345 + * previously imported commands should be
1.1346 + * removed. NULL for current namespace. */
1.1347 + CONST char *pattern; /* String pattern indicating which imported
1.1348 + * commands to remove. */
1.1349 +{
1.1350 + Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
1.1351 + CONST char *simplePattern;
1.1352 + char *cmdName;
1.1353 + register Tcl_HashEntry *hPtr;
1.1354 + Tcl_HashSearch search;
1.1355 +
1.1356 + /*
1.1357 + * If the specified namespace is NULL, use the current namespace.
1.1358 + */
1.1359 +
1.1360 + if (namespacePtr == NULL) {
1.1361 + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.1362 + } else {
1.1363 + nsPtr = (Namespace *) namespacePtr;
1.1364 + }
1.1365 +
1.1366 + /*
1.1367 + * Parse the pattern into its namespace-qualification (if any)
1.1368 + * and the simple pattern.
1.1369 + */
1.1370 +
1.1371 + TclGetNamespaceForQualName(interp, pattern, nsPtr,
1.1372 + /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY),
1.1373 + &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1.1374 +
1.1375 + if (sourceNsPtr == NULL) {
1.1376 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1377 + "unknown namespace in namespace forget pattern \"",
1.1378 + pattern, "\"", (char *) NULL);
1.1379 + return TCL_ERROR;
1.1380 + }
1.1381 +
1.1382 + if (strcmp(pattern, simplePattern) == 0) {
1.1383 + /*
1.1384 + * The pattern is simple.
1.1385 + * Delete any imported commands that match it.
1.1386 + */
1.1387 +
1.1388 + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1.1389 + (hPtr != NULL);
1.1390 + hPtr = Tcl_NextHashEntry(&search)) {
1.1391 + Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
1.1392 + if (cmdPtr->deleteProc != DeleteImportedCmd) {
1.1393 + continue;
1.1394 + }
1.1395 + cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
1.1396 + if (Tcl_StringMatch(cmdName, simplePattern)) {
1.1397 + Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1.1398 + }
1.1399 + }
1.1400 + return TCL_OK;
1.1401 + }
1.1402 +
1.1403 + /* The pattern was namespace-qualified */
1.1404 +
1.1405 + for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
1.1406 + hPtr = Tcl_NextHashEntry(&search)) {
1.1407 + Tcl_CmdInfo info;
1.1408 + Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr);
1.1409 + Tcl_Command origin = TclGetOriginalCommand(token);
1.1410 +
1.1411 + if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
1.1412 + continue; /* Not an imported command */
1.1413 + }
1.1414 + if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1.1415 + /*
1.1416 + * Original not in namespace we're matching.
1.1417 + * Check the first link in the import chain.
1.1418 + */
1.1419 + Command *cmdPtr = (Command *) token;
1.1420 + ImportedCmdData *dataPtr =
1.1421 + (ImportedCmdData *) cmdPtr->objClientData;
1.1422 + Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
1.1423 + if (firstToken == origin) {
1.1424 + continue;
1.1425 + }
1.1426 + Tcl_GetCommandInfoFromToken(firstToken, &info);
1.1427 + if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1.1428 + continue;
1.1429 + }
1.1430 + origin = firstToken;
1.1431 + }
1.1432 + if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
1.1433 + Tcl_DeleteCommandFromToken(interp, token);
1.1434 + }
1.1435 + }
1.1436 + return TCL_OK;
1.1437 +}
1.1438 +
1.1439 +/*
1.1440 + *----------------------------------------------------------------------
1.1441 + *
1.1442 + * TclGetOriginalCommand --
1.1443 + *
1.1444 + * An imported command is created in an namespace when a "real" command
1.1445 + * is imported from another namespace. If the specified command is an
1.1446 + * imported command, this procedure returns the original command it
1.1447 + * refers to.
1.1448 + *
1.1449 + * Results:
1.1450 + * If the command was imported into a sequence of namespaces a, b,...,n
1.1451 + * where each successive namespace just imports the command from the
1.1452 + * previous namespace, this procedure returns the Tcl_Command token in
1.1453 + * the first namespace, a. Otherwise, if the specified command is not
1.1454 + * an imported command, the procedure returns NULL.
1.1455 + *
1.1456 + * Side effects:
1.1457 + * None.
1.1458 + *
1.1459 + *----------------------------------------------------------------------
1.1460 + */
1.1461 +
1.1462 +Tcl_Command
1.1463 +TclGetOriginalCommand(command)
1.1464 + Tcl_Command command; /* The imported command for which the
1.1465 + * original command should be returned. */
1.1466 +{
1.1467 + register Command *cmdPtr = (Command *) command;
1.1468 + ImportedCmdData *dataPtr;
1.1469 +
1.1470 + if (cmdPtr->deleteProc != DeleteImportedCmd) {
1.1471 + return (Tcl_Command) NULL;
1.1472 + }
1.1473 +
1.1474 + while (cmdPtr->deleteProc == DeleteImportedCmd) {
1.1475 + dataPtr = (ImportedCmdData *) cmdPtr->objClientData;
1.1476 + cmdPtr = dataPtr->realCmdPtr;
1.1477 + }
1.1478 + return (Tcl_Command) cmdPtr;
1.1479 +}
1.1480 +
1.1481 +/*
1.1482 + *----------------------------------------------------------------------
1.1483 + *
1.1484 + * InvokeImportedCmd --
1.1485 + *
1.1486 + * Invoked by Tcl whenever the user calls an imported command that
1.1487 + * was created by Tcl_Import. Finds the "real" command (in another
1.1488 + * namespace), and passes control to it.
1.1489 + *
1.1490 + * Results:
1.1491 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.1492 + *
1.1493 + * Side effects:
1.1494 + * Returns a result in the interpreter's result object. If anything
1.1495 + * goes wrong, the result object is set to an error message.
1.1496 + *
1.1497 + *----------------------------------------------------------------------
1.1498 + */
1.1499 +
1.1500 +static int
1.1501 +InvokeImportedCmd(clientData, interp, objc, objv)
1.1502 + ClientData clientData; /* Points to the imported command's
1.1503 + * ImportedCmdData structure. */
1.1504 + Tcl_Interp *interp; /* Current interpreter. */
1.1505 + int objc; /* Number of arguments. */
1.1506 + Tcl_Obj *CONST objv[]; /* The argument objects. */
1.1507 +{
1.1508 + register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
1.1509 + register Command *realCmdPtr = dataPtr->realCmdPtr;
1.1510 +
1.1511 + return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
1.1512 + objc, objv);
1.1513 +}
1.1514 +
1.1515 +/*
1.1516 + *----------------------------------------------------------------------
1.1517 + *
1.1518 + * DeleteImportedCmd --
1.1519 + *
1.1520 + * Invoked by Tcl whenever an imported command is deleted. The "real"
1.1521 + * command keeps a list of all the imported commands that refer to it,
1.1522 + * so those imported commands can be deleted when the real command is
1.1523 + * deleted. This procedure removes the imported command reference from
1.1524 + * the real command's list, and frees up the memory associated with
1.1525 + * the imported command.
1.1526 + *
1.1527 + * Results:
1.1528 + * None.
1.1529 + *
1.1530 + * Side effects:
1.1531 + * Removes the imported command from the real command's import list.
1.1532 + *
1.1533 + *----------------------------------------------------------------------
1.1534 + */
1.1535 +
1.1536 +static void
1.1537 +DeleteImportedCmd(clientData)
1.1538 + ClientData clientData; /* Points to the imported command's
1.1539 + * ImportedCmdData structure. */
1.1540 +{
1.1541 + ImportedCmdData *dataPtr = (ImportedCmdData *) clientData;
1.1542 + Command *realCmdPtr = dataPtr->realCmdPtr;
1.1543 + Command *selfPtr = dataPtr->selfPtr;
1.1544 + register ImportRef *refPtr, *prevPtr;
1.1545 +
1.1546 + prevPtr = NULL;
1.1547 + for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
1.1548 + refPtr = refPtr->nextPtr) {
1.1549 + if (refPtr->importedCmdPtr == selfPtr) {
1.1550 + /*
1.1551 + * Remove *refPtr from real command's list of imported commands
1.1552 + * that refer to it.
1.1553 + */
1.1554 +
1.1555 + if (prevPtr == NULL) { /* refPtr is first in list */
1.1556 + realCmdPtr->importRefPtr = refPtr->nextPtr;
1.1557 + } else {
1.1558 + prevPtr->nextPtr = refPtr->nextPtr;
1.1559 + }
1.1560 + ckfree((char *) refPtr);
1.1561 + ckfree((char *) dataPtr);
1.1562 + return;
1.1563 + }
1.1564 + prevPtr = refPtr;
1.1565 + }
1.1566 +
1.1567 + panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
1.1568 +}
1.1569 +
1.1570 +/*
1.1571 + *----------------------------------------------------------------------
1.1572 + *
1.1573 + * TclGetNamespaceForQualName --
1.1574 + *
1.1575 + * Given a qualified name specifying a command, variable, or namespace,
1.1576 + * and a namespace in which to resolve the name, this procedure returns
1.1577 + * a pointer to the namespace that contains the item. A qualified name
1.1578 + * consists of the "simple" name of an item qualified by the names of
1.1579 + * an arbitrary number of containing namespace separated by "::"s. If
1.1580 + * the qualified name starts with "::", it is interpreted absolutely
1.1581 + * from the global namespace. Otherwise, it is interpreted relative to
1.1582 + * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr
1.1583 + * is NULL, the name is interpreted relative to the current namespace.
1.1584 + *
1.1585 + * A relative name like "foo::bar::x" can be found starting in either
1.1586 + * the current namespace or in the global namespace. So each search
1.1587 + * usually follows two tracks, and two possible namespaces are
1.1588 + * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to
1.1589 + * NULL, then that path failed.
1.1590 + *
1.1591 + * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
1.1592 + * sought only in the global :: namespace. The alternate search
1.1593 + * (also) starting from the global namespace is ignored and
1.1594 + * *altNsPtrPtr is set NULL.
1.1595 + *
1.1596 + * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified
1.1597 + * name is sought only in the namespace specified by cxtNsPtr. The
1.1598 + * alternate search starting from the global namespace is ignored and
1.1599 + * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and
1.1600 + * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and
1.1601 + * the search starts from the namespace specified by cxtNsPtr.
1.1602 + *
1.1603 + * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace
1.1604 + * components of the qualified name that cannot be found are
1.1605 + * automatically created within their specified parent. This makes sure
1.1606 + * that functions like Tcl_CreateCommand always succeed. There is no
1.1607 + * alternate search path, so *altNsPtrPtr is set NULL.
1.1608 + *
1.1609 + * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a
1.1610 + * reference to a namespace, and the entire qualified name is
1.1611 + * followed. If the name is relative, the namespace is looked up only
1.1612 + * in the current namespace. A pointer to the namespace is stored in
1.1613 + * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if
1.1614 + * FIND_ONLY_NS is not specified, only the leading components are
1.1615 + * treated as namespace names, and a pointer to the simple name of the
1.1616 + * final component is stored in *simpleNamePtr.
1.1617 + *
1.1618 + * Results:
1.1619 + * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
1.1620 + * namespaces which represent the last (containing) namespace in the
1.1621 + * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr
1.1622 + * to NULL, then the search along that path failed. The procedure also
1.1623 + * stores a pointer to the simple name of the final component in
1.1624 + * *simpleNamePtr. If the qualified name is "::" or was treated as a
1.1625 + * namespace reference (FIND_ONLY_NS), the procedure stores a pointer
1.1626 + * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
1.1627 + * *simpleNamePtr to point to an empty string.
1.1628 + *
1.1629 + * If there is an error, this procedure returns TCL_ERROR. If "flags"
1.1630 + * contains TCL_LEAVE_ERR_MSG, an error message is returned in the
1.1631 + * interpreter's result object. Otherwise, the interpreter's result
1.1632 + * object is left unchanged.
1.1633 + *
1.1634 + * *actualCxtPtrPtr is set to the actual context namespace. It is
1.1635 + * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr
1.1636 + * is NULL, it is set to the current namespace context.
1.1637 + *
1.1638 + * For backwards compatibility with the TclPro byte code loader,
1.1639 + * this function always returns TCL_OK.
1.1640 + *
1.1641 + * Side effects:
1.1642 + * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be
1.1643 + * created.
1.1644 + *
1.1645 + *----------------------------------------------------------------------
1.1646 + */
1.1647 +
1.1648 +int
1.1649 +TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
1.1650 + nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr)
1.1651 + Tcl_Interp *interp; /* Interpreter in which to find the
1.1652 + * namespace containing qualName. */
1.1653 + CONST char *qualName; /* A namespace-qualified name of an
1.1654 + * command, variable, or namespace. */
1.1655 + Namespace *cxtNsPtr; /* The namespace in which to start the
1.1656 + * search for qualName's namespace. If NULL
1.1657 + * start from the current namespace.
1.1658 + * Ignored if TCL_GLOBAL_ONLY is set. */
1.1659 + int flags; /* Flags controlling the search: an OR'd
1.1660 + * combination of TCL_GLOBAL_ONLY,
1.1661 + * TCL_NAMESPACE_ONLY,
1.1662 + * CREATE_NS_IF_UNKNOWN, and
1.1663 + * FIND_ONLY_NS. */
1.1664 + Namespace **nsPtrPtr; /* Address where procedure stores a pointer
1.1665 + * to containing namespace if qualName is
1.1666 + * found starting from *cxtNsPtr or, if
1.1667 + * TCL_GLOBAL_ONLY is set, if qualName is
1.1668 + * found in the global :: namespace. NULL
1.1669 + * is stored otherwise. */
1.1670 + Namespace **altNsPtrPtr; /* Address where procedure stores a pointer
1.1671 + * to containing namespace if qualName is
1.1672 + * found starting from the global ::
1.1673 + * namespace. NULL is stored if qualName
1.1674 + * isn't found starting from :: or if the
1.1675 + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY,
1.1676 + * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag
1.1677 + * is set. */
1.1678 + Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer
1.1679 + * to the actual namespace from which the
1.1680 + * search started. This is either cxtNsPtr,
1.1681 + * the :: namespace if TCL_GLOBAL_ONLY was
1.1682 + * specified, or the current namespace if
1.1683 + * cxtNsPtr was NULL. */
1.1684 + CONST char **simpleNamePtr; /* Address where procedure stores the
1.1685 + * simple name at end of the qualName, or
1.1686 + * NULL if qualName is "::" or the flag
1.1687 + * FIND_ONLY_NS was specified. */
1.1688 +{
1.1689 + Interp *iPtr = (Interp *) interp;
1.1690 + Namespace *nsPtr = cxtNsPtr;
1.1691 + Namespace *altNsPtr;
1.1692 + Namespace *globalNsPtr = iPtr->globalNsPtr;
1.1693 + CONST char *start, *end;
1.1694 + CONST char *nsName;
1.1695 + Tcl_HashEntry *entryPtr;
1.1696 + Tcl_DString buffer;
1.1697 + int len;
1.1698 +
1.1699 + /*
1.1700 + * Determine the context namespace nsPtr in which to start the primary
1.1701 + * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY
1.1702 + * was specified, search from the global namespace. Otherwise, use the
1.1703 + * namespace given in cxtNsPtr, or if that is NULL, use the current
1.1704 + * namespace context. Note that we always treat two or more
1.1705 + * adjacent ":"s as a namespace separator.
1.1706 + */
1.1707 +
1.1708 + if (flags & TCL_GLOBAL_ONLY) {
1.1709 + nsPtr = globalNsPtr;
1.1710 + } else if (nsPtr == NULL) {
1.1711 + if (iPtr->varFramePtr != NULL) {
1.1712 + nsPtr = iPtr->varFramePtr->nsPtr;
1.1713 + } else {
1.1714 + nsPtr = iPtr->globalNsPtr;
1.1715 + }
1.1716 + }
1.1717 +
1.1718 + start = qualName; /* pts to start of qualifying namespace */
1.1719 + if ((*qualName == ':') && (*(qualName+1) == ':')) {
1.1720 + start = qualName+2; /* skip over the initial :: */
1.1721 + while (*start == ':') {
1.1722 + start++; /* skip over a subsequent : */
1.1723 + }
1.1724 + nsPtr = globalNsPtr;
1.1725 + if (*start == '\0') { /* qualName is just two or more ":"s */
1.1726 + *nsPtrPtr = globalNsPtr;
1.1727 + *altNsPtrPtr = NULL;
1.1728 + *actualCxtPtrPtr = globalNsPtr;
1.1729 + *simpleNamePtr = start; /* points to empty string */
1.1730 + return TCL_OK;
1.1731 + }
1.1732 + }
1.1733 + *actualCxtPtrPtr = nsPtr;
1.1734 +
1.1735 + /*
1.1736 + * Start an alternate search path starting with the global namespace.
1.1737 + * However, if the starting context is the global namespace, or if the
1.1738 + * flag is set to search only the namespace *cxtNsPtr, ignore the
1.1739 + * alternate search path.
1.1740 + */
1.1741 +
1.1742 + altNsPtr = globalNsPtr;
1.1743 + if ((nsPtr == globalNsPtr)
1.1744 + || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) {
1.1745 + altNsPtr = NULL;
1.1746 + }
1.1747 +
1.1748 + /*
1.1749 + * Loop to resolve each namespace qualifier in qualName.
1.1750 + */
1.1751 +
1.1752 + Tcl_DStringInit(&buffer);
1.1753 + end = start;
1.1754 + while (*start != '\0') {
1.1755 + /*
1.1756 + * Find the next namespace qualifier (i.e., a name ending in "::")
1.1757 + * or the end of the qualified name (i.e., a name ending in "\0").
1.1758 + * Set len to the number of characters, starting from start,
1.1759 + * in the name; set end to point after the "::"s or at the "\0".
1.1760 + */
1.1761 +
1.1762 + len = 0;
1.1763 + for (end = start; *end != '\0'; end++) {
1.1764 + if ((*end == ':') && (*(end+1) == ':')) {
1.1765 + end += 2; /* skip over the initial :: */
1.1766 + while (*end == ':') {
1.1767 + end++; /* skip over the subsequent : */
1.1768 + }
1.1769 + break; /* exit for loop; end is after ::'s */
1.1770 + }
1.1771 + len++;
1.1772 + }
1.1773 +
1.1774 + if ((*end == '\0')
1.1775 + && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
1.1776 + /*
1.1777 + * qualName ended with a simple name at start. If FIND_ONLY_NS
1.1778 + * was specified, look this up as a namespace. Otherwise,
1.1779 + * start is the name of a cmd or var and we are done.
1.1780 + */
1.1781 +
1.1782 + if (flags & FIND_ONLY_NS) {
1.1783 + nsName = start;
1.1784 + } else {
1.1785 + *nsPtrPtr = nsPtr;
1.1786 + *altNsPtrPtr = altNsPtr;
1.1787 + *simpleNamePtr = start;
1.1788 + Tcl_DStringFree(&buffer);
1.1789 + return TCL_OK;
1.1790 + }
1.1791 + } else {
1.1792 + /*
1.1793 + * start points to the beginning of a namespace qualifier ending
1.1794 + * in "::". end points to the start of a name in that namespace
1.1795 + * that might be empty. Copy the namespace qualifier to a
1.1796 + * buffer so it can be null terminated. We can't modify the
1.1797 + * incoming qualName since it may be a string constant.
1.1798 + */
1.1799 +
1.1800 + Tcl_DStringSetLength(&buffer, 0);
1.1801 + Tcl_DStringAppend(&buffer, start, len);
1.1802 + nsName = Tcl_DStringValue(&buffer);
1.1803 + }
1.1804 +
1.1805 + /*
1.1806 + * Look up the namespace qualifier nsName in the current namespace
1.1807 + * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set,
1.1808 + * create that qualifying namespace. This is needed for procedures
1.1809 + * like Tcl_CreateCommand that cannot fail.
1.1810 + */
1.1811 +
1.1812 + if (nsPtr != NULL) {
1.1813 + entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
1.1814 + if (entryPtr != NULL) {
1.1815 + nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
1.1816 + } else if (flags & CREATE_NS_IF_UNKNOWN) {
1.1817 + Tcl_CallFrame frame;
1.1818 +
1.1819 + (void) Tcl_PushCallFrame(interp, &frame,
1.1820 + (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
1.1821 +
1.1822 + nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
1.1823 + (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL);
1.1824 + Tcl_PopCallFrame(interp);
1.1825 +
1.1826 + if (nsPtr == NULL) {
1.1827 + panic("Could not create namespace '%s'", nsName);
1.1828 + }
1.1829 + } else { /* namespace not found and wasn't created */
1.1830 + nsPtr = NULL;
1.1831 + }
1.1832 + }
1.1833 +
1.1834 + /*
1.1835 + * Look up the namespace qualifier in the alternate search path too.
1.1836 + */
1.1837 +
1.1838 + if (altNsPtr != NULL) {
1.1839 + entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
1.1840 + if (entryPtr != NULL) {
1.1841 + altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
1.1842 + } else {
1.1843 + altNsPtr = NULL;
1.1844 + }
1.1845 + }
1.1846 +
1.1847 + /*
1.1848 + * If both search paths have failed, return NULL results.
1.1849 + */
1.1850 +
1.1851 + if ((nsPtr == NULL) && (altNsPtr == NULL)) {
1.1852 + *nsPtrPtr = NULL;
1.1853 + *altNsPtrPtr = NULL;
1.1854 + *simpleNamePtr = NULL;
1.1855 + Tcl_DStringFree(&buffer);
1.1856 + return TCL_OK;
1.1857 + }
1.1858 +
1.1859 + start = end;
1.1860 + }
1.1861 +
1.1862 + /*
1.1863 + * We ignore trailing "::"s in a namespace name, but in a command or
1.1864 + * variable name, trailing "::"s refer to the cmd or var named {}.
1.1865 + */
1.1866 +
1.1867 + if ((flags & FIND_ONLY_NS)
1.1868 + || ((end > start ) && (*(end-1) != ':'))) {
1.1869 + *simpleNamePtr = NULL; /* found namespace name */
1.1870 + } else {
1.1871 + *simpleNamePtr = end; /* found cmd/var: points to empty string */
1.1872 + }
1.1873 +
1.1874 + /*
1.1875 + * As a special case, if we are looking for a namespace and qualName
1.1876 + * is "" and the current active namespace (nsPtr) is not the global
1.1877 + * namespace, return NULL (no namespace was found). This is because
1.1878 + * namespaces can not have empty names except for the global namespace.
1.1879 + */
1.1880 +
1.1881 + if ((flags & FIND_ONLY_NS) && (*qualName == '\0')
1.1882 + && (nsPtr != globalNsPtr)) {
1.1883 + nsPtr = NULL;
1.1884 + }
1.1885 +
1.1886 + *nsPtrPtr = nsPtr;
1.1887 + *altNsPtrPtr = altNsPtr;
1.1888 + Tcl_DStringFree(&buffer);
1.1889 + return TCL_OK;
1.1890 +}
1.1891 +
1.1892 +/*
1.1893 + *----------------------------------------------------------------------
1.1894 + *
1.1895 + * Tcl_FindNamespace --
1.1896 + *
1.1897 + * Searches for a namespace.
1.1898 + *
1.1899 + * Results:
1.1900 + * Returns a pointer to the namespace if it is found. Otherwise,
1.1901 + * returns NULL and leaves an error message in the interpreter's
1.1902 + * result object if "flags" contains TCL_LEAVE_ERR_MSG.
1.1903 + *
1.1904 + * Side effects:
1.1905 + * None.
1.1906 + *
1.1907 + *----------------------------------------------------------------------
1.1908 + */
1.1909 +
1.1910 +Tcl_Namespace *
1.1911 +Tcl_FindNamespace(interp, name, contextNsPtr, flags)
1.1912 + Tcl_Interp *interp; /* The interpreter in which to find the
1.1913 + * namespace. */
1.1914 + CONST char *name; /* Namespace name. If it starts with "::",
1.1915 + * will be looked up in global namespace.
1.1916 + * Else, looked up first in contextNsPtr
1.1917 + * (current namespace if contextNsPtr is
1.1918 + * NULL), then in global namespace. */
1.1919 + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set
1.1920 + * or if the name starts with "::".
1.1921 + * Otherwise, points to namespace in which
1.1922 + * to resolve name; if NULL, look up name
1.1923 + * in the current namespace. */
1.1924 + register int flags; /* Flags controlling namespace lookup: an
1.1925 + * OR'd combination of TCL_GLOBAL_ONLY and
1.1926 + * TCL_LEAVE_ERR_MSG flags. */
1.1927 +{
1.1928 + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
1.1929 + CONST char *dummy;
1.1930 +
1.1931 + /*
1.1932 + * Find the namespace(s) that contain the specified namespace name.
1.1933 + * Add the FIND_ONLY_NS flag to resolve the name all the way down
1.1934 + * to its last component, a namespace.
1.1935 + */
1.1936 +
1.1937 + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
1.1938 + (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
1.1939 +
1.1940 + if (nsPtr != NULL) {
1.1941 + return (Tcl_Namespace *) nsPtr;
1.1942 + } else if (flags & TCL_LEAVE_ERR_MSG) {
1.1943 + Tcl_ResetResult(interp);
1.1944 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.1945 + "unknown namespace \"", name, "\"", (char *) NULL);
1.1946 + }
1.1947 + return NULL;
1.1948 +}
1.1949 +
1.1950 +/*
1.1951 + *----------------------------------------------------------------------
1.1952 + *
1.1953 + * Tcl_FindCommand --
1.1954 + *
1.1955 + * Searches for a command.
1.1956 + *
1.1957 + * Results:
1.1958 + * Returns a token for the command if it is found. Otherwise, if it
1.1959 + * can't be found or there is an error, returns NULL and leaves an
1.1960 + * error message in the interpreter's result object if "flags"
1.1961 + * contains TCL_LEAVE_ERR_MSG.
1.1962 + *
1.1963 + * Side effects:
1.1964 + * None.
1.1965 + *
1.1966 + *----------------------------------------------------------------------
1.1967 + */
1.1968 +
1.1969 +Tcl_Command
1.1970 +Tcl_FindCommand(interp, name, contextNsPtr, flags)
1.1971 + Tcl_Interp *interp; /* The interpreter in which to find the
1.1972 + * command and to report errors. */
1.1973 + CONST char *name; /* Command's name. If it starts with "::",
1.1974 + * will be looked up in global namespace.
1.1975 + * Else, looked up first in contextNsPtr
1.1976 + * (current namespace if contextNsPtr is
1.1977 + * NULL), then in global namespace. */
1.1978 + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
1.1979 + * Otherwise, points to namespace in which
1.1980 + * to resolve name. If NULL, look up name
1.1981 + * in the current namespace. */
1.1982 + int flags; /* An OR'd combination of flags:
1.1983 + * TCL_GLOBAL_ONLY (look up name only in
1.1984 + * global namespace), TCL_NAMESPACE_ONLY
1.1985 + * (look up only in contextNsPtr, or the
1.1986 + * current namespace if contextNsPtr is
1.1987 + * NULL), and TCL_LEAVE_ERR_MSG. If both
1.1988 + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
1.1989 + * are given, TCL_GLOBAL_ONLY is
1.1990 + * ignored. */
1.1991 +{
1.1992 + Interp *iPtr = (Interp*)interp;
1.1993 +
1.1994 + ResolverScheme *resPtr;
1.1995 + Namespace *nsPtr[2], *cxtNsPtr;
1.1996 + CONST char *simpleName;
1.1997 + register Tcl_HashEntry *entryPtr;
1.1998 + register Command *cmdPtr;
1.1999 + register int search;
1.2000 + int result;
1.2001 + Tcl_Command cmd;
1.2002 +
1.2003 + /*
1.2004 + * If this namespace has a command resolver, then give it first
1.2005 + * crack at the command resolution. If the interpreter has any
1.2006 + * command resolvers, consult them next. The command resolver
1.2007 + * procedures may return a Tcl_Command value, they may signal
1.2008 + * to continue onward, or they may signal an error.
1.2009 + */
1.2010 + if ((flags & TCL_GLOBAL_ONLY) != 0) {
1.2011 + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.2012 + }
1.2013 + else if (contextNsPtr != NULL) {
1.2014 + cxtNsPtr = (Namespace *) contextNsPtr;
1.2015 + }
1.2016 + else {
1.2017 + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2018 + }
1.2019 +
1.2020 + if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
1.2021 + resPtr = iPtr->resolverPtr;
1.2022 +
1.2023 + if (cxtNsPtr->cmdResProc) {
1.2024 + result = (*cxtNsPtr->cmdResProc)(interp, name,
1.2025 + (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
1.2026 + } else {
1.2027 + result = TCL_CONTINUE;
1.2028 + }
1.2029 +
1.2030 + while (result == TCL_CONTINUE && resPtr) {
1.2031 + if (resPtr->cmdResProc) {
1.2032 + result = (*resPtr->cmdResProc)(interp, name,
1.2033 + (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
1.2034 + }
1.2035 + resPtr = resPtr->nextPtr;
1.2036 + }
1.2037 +
1.2038 + if (result == TCL_OK) {
1.2039 + return cmd;
1.2040 + }
1.2041 + else if (result != TCL_CONTINUE) {
1.2042 + return (Tcl_Command) NULL;
1.2043 + }
1.2044 + }
1.2045 +
1.2046 + /*
1.2047 + * Find the namespace(s) that contain the command.
1.2048 + */
1.2049 +
1.2050 + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
1.2051 + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
1.2052 +
1.2053 + /*
1.2054 + * Look for the command in the command table of its namespace.
1.2055 + * Be sure to check both possible search paths: from the specified
1.2056 + * namespace context and from the global namespace.
1.2057 + */
1.2058 +
1.2059 + cmdPtr = NULL;
1.2060 + for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
1.2061 + if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
1.2062 + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
1.2063 + simpleName);
1.2064 + if (entryPtr != NULL) {
1.2065 + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
1.2066 + }
1.2067 + }
1.2068 + }
1.2069 +
1.2070 + if (cmdPtr != NULL) {
1.2071 + return (Tcl_Command) cmdPtr;
1.2072 + } else if (flags & TCL_LEAVE_ERR_MSG) {
1.2073 + Tcl_ResetResult(interp);
1.2074 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2075 + "unknown command \"", name, "\"", (char *) NULL);
1.2076 + }
1.2077 +
1.2078 + return (Tcl_Command) NULL;
1.2079 +}
1.2080 +
1.2081 +/*
1.2082 + *----------------------------------------------------------------------
1.2083 + *
1.2084 + * Tcl_FindNamespaceVar --
1.2085 + *
1.2086 + * Searches for a namespace variable, a variable not local to a
1.2087 + * procedure. The variable can be either a scalar or an array, but
1.2088 + * may not be an element of an array.
1.2089 + *
1.2090 + * Results:
1.2091 + * Returns a token for the variable if it is found. Otherwise, if it
1.2092 + * can't be found or there is an error, returns NULL and leaves an
1.2093 + * error message in the interpreter's result object if "flags"
1.2094 + * contains TCL_LEAVE_ERR_MSG.
1.2095 + *
1.2096 + * Side effects:
1.2097 + * None.
1.2098 + *
1.2099 + *----------------------------------------------------------------------
1.2100 + */
1.2101 +
1.2102 +Tcl_Var
1.2103 +Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags)
1.2104 + Tcl_Interp *interp; /* The interpreter in which to find the
1.2105 + * variable. */
1.2106 + CONST char *name; /* Variable's name. If it starts with "::",
1.2107 + * will be looked up in global namespace.
1.2108 + * Else, looked up first in contextNsPtr
1.2109 + * (current namespace if contextNsPtr is
1.2110 + * NULL), then in global namespace. */
1.2111 + Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set.
1.2112 + * Otherwise, points to namespace in which
1.2113 + * to resolve name. If NULL, look up name
1.2114 + * in the current namespace. */
1.2115 + int flags; /* An OR'd combination of flags:
1.2116 + * TCL_GLOBAL_ONLY (look up name only in
1.2117 + * global namespace), TCL_NAMESPACE_ONLY
1.2118 + * (look up only in contextNsPtr, or the
1.2119 + * current namespace if contextNsPtr is
1.2120 + * NULL), and TCL_LEAVE_ERR_MSG. If both
1.2121 + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY
1.2122 + * are given, TCL_GLOBAL_ONLY is
1.2123 + * ignored. */
1.2124 +{
1.2125 + Interp *iPtr = (Interp*)interp;
1.2126 + ResolverScheme *resPtr;
1.2127 + Namespace *nsPtr[2], *cxtNsPtr;
1.2128 + CONST char *simpleName;
1.2129 + Tcl_HashEntry *entryPtr;
1.2130 + Var *varPtr;
1.2131 + register int search;
1.2132 + int result;
1.2133 + Tcl_Var var;
1.2134 +
1.2135 + /*
1.2136 + * If this namespace has a variable resolver, then give it first
1.2137 + * crack at the variable resolution. It may return a Tcl_Var
1.2138 + * value, it may signal to continue onward, or it may signal
1.2139 + * an error.
1.2140 + */
1.2141 + if ((flags & TCL_GLOBAL_ONLY) != 0) {
1.2142 + cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.2143 + }
1.2144 + else if (contextNsPtr != NULL) {
1.2145 + cxtNsPtr = (Namespace *) contextNsPtr;
1.2146 + }
1.2147 + else {
1.2148 + cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2149 + }
1.2150 +
1.2151 + if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) {
1.2152 + resPtr = iPtr->resolverPtr;
1.2153 +
1.2154 + if (cxtNsPtr->varResProc) {
1.2155 + result = (*cxtNsPtr->varResProc)(interp, name,
1.2156 + (Tcl_Namespace *) cxtNsPtr, flags, &var);
1.2157 + } else {
1.2158 + result = TCL_CONTINUE;
1.2159 + }
1.2160 +
1.2161 + while (result == TCL_CONTINUE && resPtr) {
1.2162 + if (resPtr->varResProc) {
1.2163 + result = (*resPtr->varResProc)(interp, name,
1.2164 + (Tcl_Namespace *) cxtNsPtr, flags, &var);
1.2165 + }
1.2166 + resPtr = resPtr->nextPtr;
1.2167 + }
1.2168 +
1.2169 + if (result == TCL_OK) {
1.2170 + return var;
1.2171 + }
1.2172 + else if (result != TCL_CONTINUE) {
1.2173 + return (Tcl_Var) NULL;
1.2174 + }
1.2175 + }
1.2176 +
1.2177 + /*
1.2178 + * Find the namespace(s) that contain the variable.
1.2179 + */
1.2180 +
1.2181 + TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
1.2182 + flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
1.2183 +
1.2184 + /*
1.2185 + * Look for the variable in the variable table of its namespace.
1.2186 + * Be sure to check both possible search paths: from the specified
1.2187 + * namespace context and from the global namespace.
1.2188 + */
1.2189 +
1.2190 + varPtr = NULL;
1.2191 + for (search = 0; (search < 2) && (varPtr == NULL); search++) {
1.2192 + if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
1.2193 + entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable,
1.2194 + simpleName);
1.2195 + if (entryPtr != NULL) {
1.2196 + varPtr = (Var *) Tcl_GetHashValue(entryPtr);
1.2197 + }
1.2198 + }
1.2199 + }
1.2200 + if (varPtr != NULL) {
1.2201 + return (Tcl_Var) varPtr;
1.2202 + } else if (flags & TCL_LEAVE_ERR_MSG) {
1.2203 + Tcl_ResetResult(interp);
1.2204 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2205 + "unknown variable \"", name, "\"", (char *) NULL);
1.2206 + }
1.2207 + return (Tcl_Var) NULL;
1.2208 +}
1.2209 +
1.2210 +/*
1.2211 + *----------------------------------------------------------------------
1.2212 + *
1.2213 + * TclResetShadowedCmdRefs --
1.2214 + *
1.2215 + * Called when a command is added to a namespace to check for existing
1.2216 + * command references that the new command may invalidate. Consider the
1.2217 + * following cases that could happen when you add a command "foo" to a
1.2218 + * namespace "b":
1.2219 + * 1. It could shadow a command named "foo" at the global scope.
1.2220 + * If it does, all command references in the namespace "b" are
1.2221 + * suspect.
1.2222 + * 2. Suppose the namespace "b" resides in a namespace "a".
1.2223 + * Then to "a" the new command "b::foo" could shadow another
1.2224 + * command "b::foo" in the global namespace. If so, then all
1.2225 + * command references in "a" are suspect.
1.2226 + * The same checks are applied to all parent namespaces, until we
1.2227 + * reach the global :: namespace.
1.2228 + *
1.2229 + * Results:
1.2230 + * None.
1.2231 + *
1.2232 + * Side effects:
1.2233 + * If the new command shadows an existing command, the cmdRefEpoch
1.2234 + * counter is incremented in each namespace that sees the shadow.
1.2235 + * This invalidates all command references that were previously cached
1.2236 + * in that namespace. The next time the commands are used, they are
1.2237 + * resolved from scratch.
1.2238 + *
1.2239 + *----------------------------------------------------------------------
1.2240 + */
1.2241 +
1.2242 +void
1.2243 +TclResetShadowedCmdRefs(interp, newCmdPtr)
1.2244 + Tcl_Interp *interp; /* Interpreter containing the new command. */
1.2245 + Command *newCmdPtr; /* Points to the new command. */
1.2246 +{
1.2247 + char *cmdName;
1.2248 + Tcl_HashEntry *hPtr;
1.2249 + register Namespace *nsPtr;
1.2250 + Namespace *trailNsPtr, *shadowNsPtr;
1.2251 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.2252 + int found, i;
1.2253 +
1.2254 + /*
1.2255 + * This procedure generates an array used to hold the trail list. This
1.2256 + * starts out with stack-allocated space but uses dynamically-allocated
1.2257 + * storage if needed.
1.2258 + */
1.2259 +
1.2260 + Namespace *(trailStorage[NUM_TRAIL_ELEMS]);
1.2261 + Namespace **trailPtr = trailStorage;
1.2262 + int trailFront = -1;
1.2263 + int trailSize = NUM_TRAIL_ELEMS;
1.2264 +
1.2265 + /*
1.2266 + * Start at the namespace containing the new command, and work up
1.2267 + * through the list of parents. Stop just before the global namespace,
1.2268 + * since the global namespace can't "shadow" its own entries.
1.2269 + *
1.2270 + * The namespace "trail" list we build consists of the names of each
1.2271 + * namespace that encloses the new command, in order from outermost to
1.2272 + * innermost: for example, "a" then "b". Each iteration of this loop
1.2273 + * eventually extends the trail upwards by one namespace, nsPtr. We use
1.2274 + * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
1.2275 + * now-invalid cached command references. This will happen if nsPtr
1.2276 + * (e.g. "a") contains a sequence of child namespaces (e.g. "b")
1.2277 + * such that there is a identically-named sequence of child namespaces
1.2278 + * starting from :: (e.g. "::b") whose tail namespace contains a command
1.2279 + * also named cmdName.
1.2280 + */
1.2281 +
1.2282 + cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
1.2283 + for (nsPtr = newCmdPtr->nsPtr;
1.2284 + (nsPtr != NULL) && (nsPtr != globalNsPtr);
1.2285 + nsPtr = nsPtr->parentPtr) {
1.2286 + /*
1.2287 + * Find the maximal sequence of child namespaces contained in nsPtr
1.2288 + * such that there is a identically-named sequence of child
1.2289 + * namespaces starting from ::. shadowNsPtr will be the tail of this
1.2290 + * sequence, or the deepest namespace under :: that might contain a
1.2291 + * command now shadowed by cmdName. We check below if shadowNsPtr
1.2292 + * actually contains a command cmdName.
1.2293 + */
1.2294 +
1.2295 + found = 1;
1.2296 + shadowNsPtr = globalNsPtr;
1.2297 +
1.2298 + for (i = trailFront; i >= 0; i--) {
1.2299 + trailNsPtr = trailPtr[i];
1.2300 + hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
1.2301 + trailNsPtr->name);
1.2302 + if (hPtr != NULL) {
1.2303 + shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr);
1.2304 + } else {
1.2305 + found = 0;
1.2306 + break;
1.2307 + }
1.2308 + }
1.2309 +
1.2310 + /*
1.2311 + * If shadowNsPtr contains a command named cmdName, we invalidate
1.2312 + * all of the command refs cached in nsPtr. As a boundary case,
1.2313 + * shadowNsPtr is initially :: and we check for case 1. above.
1.2314 + */
1.2315 +
1.2316 + if (found) {
1.2317 + hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
1.2318 + if (hPtr != NULL) {
1.2319 + nsPtr->cmdRefEpoch++;
1.2320 +
1.2321 + /*
1.2322 + * If the shadowed command was compiled to bytecodes, we
1.2323 + * invalidate all the bytecodes in nsPtr, to force a new
1.2324 + * compilation. We use the resolverEpoch to signal the need
1.2325 + * for a fresh compilation of every bytecode.
1.2326 + */
1.2327 +
1.2328 + if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) {
1.2329 + nsPtr->resolverEpoch++;
1.2330 + }
1.2331 + }
1.2332 + }
1.2333 +
1.2334 + /*
1.2335 + * Insert nsPtr at the front of the trail list: i.e., at the end
1.2336 + * of the trailPtr array.
1.2337 + */
1.2338 +
1.2339 + trailFront++;
1.2340 + if (trailFront == trailSize) {
1.2341 + size_t currBytes = trailSize * sizeof(Namespace *);
1.2342 + int newSize = 2*trailSize;
1.2343 + size_t newBytes = newSize * sizeof(Namespace *);
1.2344 + Namespace **newPtr =
1.2345 + (Namespace **) ckalloc((unsigned) newBytes);
1.2346 +
1.2347 + memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes);
1.2348 + if (trailPtr != trailStorage) {
1.2349 + ckfree((char *) trailPtr);
1.2350 + }
1.2351 + trailPtr = newPtr;
1.2352 + trailSize = newSize;
1.2353 + }
1.2354 + trailPtr[trailFront] = nsPtr;
1.2355 + }
1.2356 +
1.2357 + /*
1.2358 + * Free any allocated storage.
1.2359 + */
1.2360 +
1.2361 + if (trailPtr != trailStorage) {
1.2362 + ckfree((char *) trailPtr);
1.2363 + }
1.2364 +}
1.2365 +
1.2366 +/*
1.2367 + *----------------------------------------------------------------------
1.2368 + *
1.2369 + * GetNamespaceFromObj --
1.2370 + *
1.2371 + * Gets the namespace specified by the name in a Tcl_Obj.
1.2372 + *
1.2373 + * Results:
1.2374 + * Returns TCL_OK if the namespace was resolved successfully, and
1.2375 + * stores a pointer to the namespace in the location specified by
1.2376 + * nsPtrPtr. If the namespace can't be found, the procedure stores
1.2377 + * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong,
1.2378 + * this procedure returns TCL_ERROR.
1.2379 + *
1.2380 + * Side effects:
1.2381 + * May update the internal representation for the object, caching the
1.2382 + * namespace reference. The next time this procedure is called, the
1.2383 + * namespace value can be found quickly.
1.2384 + *
1.2385 + * If anything goes wrong, an error message is left in the
1.2386 + * interpreter's result object.
1.2387 + *
1.2388 + *----------------------------------------------------------------------
1.2389 + */
1.2390 +
1.2391 +static int
1.2392 +GetNamespaceFromObj(interp, objPtr, nsPtrPtr)
1.2393 + Tcl_Interp *interp; /* The current interpreter. */
1.2394 + Tcl_Obj *objPtr; /* The object to be resolved as the name
1.2395 + * of a namespace. */
1.2396 + Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */
1.2397 +{
1.2398 + Interp *iPtr = (Interp *) interp;
1.2399 + register ResolvedNsName *resNamePtr;
1.2400 + register Namespace *nsPtr;
1.2401 + Namespace *currNsPtr;
1.2402 + CallFrame *savedFramePtr;
1.2403 + int result = TCL_OK;
1.2404 + char *name;
1.2405 +
1.2406 + /*
1.2407 + * If the namespace name is fully qualified, do as if the lookup were
1.2408 + * done from the global namespace; this helps avoid repeated lookups
1.2409 + * of fully qualified names.
1.2410 + */
1.2411 +
1.2412 + savedFramePtr = iPtr->varFramePtr;
1.2413 + name = Tcl_GetString(objPtr);
1.2414 + if ((*name++ == ':') && (*name == ':')) {
1.2415 + iPtr->varFramePtr = NULL;
1.2416 + }
1.2417 +
1.2418 + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2419 +
1.2420 + /*
1.2421 + * Get the internal representation, converting to a namespace type if
1.2422 + * needed. The internal representation is a ResolvedNsName that points
1.2423 + * to the actual namespace.
1.2424 + */
1.2425 +
1.2426 + if (objPtr->typePtr != &tclNsNameType) {
1.2427 + result = tclNsNameType.setFromAnyProc(interp, objPtr);
1.2428 + if (result != TCL_OK) {
1.2429 + goto done;
1.2430 + }
1.2431 + }
1.2432 + resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
1.2433 +
1.2434 + /*
1.2435 + * Check the context namespace of the resolved symbol to make sure that
1.2436 + * it is fresh. If not, then force another conversion to the namespace
1.2437 + * type, to discard the old rep and create a new one. Note that we
1.2438 + * verify that the namespace id of the cached namespace is the same as
1.2439 + * the id when we cached it; this insures that the namespace wasn't
1.2440 + * deleted and a new one created at the same address.
1.2441 + */
1.2442 +
1.2443 + nsPtr = NULL;
1.2444 + if ((resNamePtr != NULL)
1.2445 + && (resNamePtr->refNsPtr == currNsPtr)
1.2446 + && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
1.2447 + nsPtr = resNamePtr->nsPtr;
1.2448 + if (nsPtr->flags & NS_DEAD) {
1.2449 + nsPtr = NULL;
1.2450 + }
1.2451 + }
1.2452 + if (nsPtr == NULL) { /* try again */
1.2453 + result = tclNsNameType.setFromAnyProc(interp, objPtr);
1.2454 + if (result != TCL_OK) {
1.2455 + goto done;
1.2456 + }
1.2457 + resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
1.2458 + if (resNamePtr != NULL) {
1.2459 + nsPtr = resNamePtr->nsPtr;
1.2460 + if (nsPtr->flags & NS_DEAD) {
1.2461 + nsPtr = NULL;
1.2462 + }
1.2463 + }
1.2464 + }
1.2465 + *nsPtrPtr = (Tcl_Namespace *) nsPtr;
1.2466 +
1.2467 + done:
1.2468 + iPtr->varFramePtr = savedFramePtr;
1.2469 + return result;
1.2470 +}
1.2471 +
1.2472 +/*
1.2473 + *----------------------------------------------------------------------
1.2474 + *
1.2475 + * Tcl_NamespaceObjCmd --
1.2476 + *
1.2477 + * Invoked to implement the "namespace" command that creates, deletes,
1.2478 + * or manipulates Tcl namespaces. Handles the following syntax:
1.2479 + *
1.2480 + * namespace children ?name? ?pattern?
1.2481 + * namespace code arg
1.2482 + * namespace current
1.2483 + * namespace delete ?name name...?
1.2484 + * namespace eval name arg ?arg...?
1.2485 + * namespace exists name
1.2486 + * namespace export ?-clear? ?pattern pattern...?
1.2487 + * namespace forget ?pattern pattern...?
1.2488 + * namespace import ?-force? ?pattern pattern...?
1.2489 + * namespace inscope name arg ?arg...?
1.2490 + * namespace origin name
1.2491 + * namespace parent ?name?
1.2492 + * namespace qualifiers string
1.2493 + * namespace tail string
1.2494 + * namespace which ?-command? ?-variable? name
1.2495 + *
1.2496 + * Results:
1.2497 + * Returns TCL_OK if the command is successful. Returns TCL_ERROR if
1.2498 + * anything goes wrong.
1.2499 + *
1.2500 + * Side effects:
1.2501 + * Based on the subcommand name (e.g., "import"), this procedure
1.2502 + * dispatches to a corresponding procedure NamespaceXXXCmd defined
1.2503 + * statically in this file. This procedure's side effects depend on
1.2504 + * whatever that subcommand procedure does. If there is an error, this
1.2505 + * procedure returns an error message in the interpreter's result
1.2506 + * object. Otherwise it may return a result in the interpreter's result
1.2507 + * object.
1.2508 + *
1.2509 + *----------------------------------------------------------------------
1.2510 + */
1.2511 +
1.2512 +int
1.2513 +Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
1.2514 + ClientData clientData; /* Arbitrary value passed to cmd. */
1.2515 + Tcl_Interp *interp; /* Current interpreter. */
1.2516 + register int objc; /* Number of arguments. */
1.2517 + register Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2518 +{
1.2519 + static CONST char *subCmds[] = {
1.2520 + "children", "code", "current", "delete",
1.2521 + "eval", "exists", "export", "forget", "import",
1.2522 + "inscope", "origin", "parent", "qualifiers",
1.2523 + "tail", "which", (char *) NULL
1.2524 + };
1.2525 + enum NSSubCmdIdx {
1.2526 + NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx,
1.2527 + NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
1.2528 + NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx,
1.2529 + NSTailIdx, NSWhichIdx
1.2530 + };
1.2531 + int index, result;
1.2532 +
1.2533 + if (objc < 2) {
1.2534 + Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
1.2535 + return TCL_ERROR;
1.2536 + }
1.2537 +
1.2538 + /*
1.2539 + * Return an index reflecting the particular subcommand.
1.2540 + */
1.2541 +
1.2542 + result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
1.2543 + "option", /*flags*/ 0, (int *) &index);
1.2544 + if (result != TCL_OK) {
1.2545 + return result;
1.2546 + }
1.2547 +
1.2548 + switch (index) {
1.2549 + case NSChildrenIdx:
1.2550 + result = NamespaceChildrenCmd(clientData, interp, objc, objv);
1.2551 + break;
1.2552 + case NSCodeIdx:
1.2553 + result = NamespaceCodeCmd(clientData, interp, objc, objv);
1.2554 + break;
1.2555 + case NSCurrentIdx:
1.2556 + result = NamespaceCurrentCmd(clientData, interp, objc, objv);
1.2557 + break;
1.2558 + case NSDeleteIdx:
1.2559 + result = NamespaceDeleteCmd(clientData, interp, objc, objv);
1.2560 + break;
1.2561 + case NSEvalIdx:
1.2562 + result = NamespaceEvalCmd(clientData, interp, objc, objv);
1.2563 + break;
1.2564 + case NSExistsIdx:
1.2565 + result = NamespaceExistsCmd(clientData, interp, objc, objv);
1.2566 + break;
1.2567 + case NSExportIdx:
1.2568 + result = NamespaceExportCmd(clientData, interp, objc, objv);
1.2569 + break;
1.2570 + case NSForgetIdx:
1.2571 + result = NamespaceForgetCmd(clientData, interp, objc, objv);
1.2572 + break;
1.2573 + case NSImportIdx:
1.2574 + result = NamespaceImportCmd(clientData, interp, objc, objv);
1.2575 + break;
1.2576 + case NSInscopeIdx:
1.2577 + result = NamespaceInscopeCmd(clientData, interp, objc, objv);
1.2578 + break;
1.2579 + case NSOriginIdx:
1.2580 + result = NamespaceOriginCmd(clientData, interp, objc, objv);
1.2581 + break;
1.2582 + case NSParentIdx:
1.2583 + result = NamespaceParentCmd(clientData, interp, objc, objv);
1.2584 + break;
1.2585 + case NSQualifiersIdx:
1.2586 + result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
1.2587 + break;
1.2588 + case NSTailIdx:
1.2589 + result = NamespaceTailCmd(clientData, interp, objc, objv);
1.2590 + break;
1.2591 + case NSWhichIdx:
1.2592 + result = NamespaceWhichCmd(clientData, interp, objc, objv);
1.2593 + break;
1.2594 + }
1.2595 + return result;
1.2596 +}
1.2597 +
1.2598 +/*
1.2599 + *----------------------------------------------------------------------
1.2600 + *
1.2601 + * NamespaceChildrenCmd --
1.2602 + *
1.2603 + * Invoked to implement the "namespace children" command that returns a
1.2604 + * list containing the fully-qualified names of the child namespaces of
1.2605 + * a given namespace. Handles the following syntax:
1.2606 + *
1.2607 + * namespace children ?name? ?pattern?
1.2608 + *
1.2609 + * Results:
1.2610 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.2611 + *
1.2612 + * Side effects:
1.2613 + * Returns a result in the interpreter's result object. If anything
1.2614 + * goes wrong, the result is an error message.
1.2615 + *
1.2616 + *----------------------------------------------------------------------
1.2617 + */
1.2618 +
1.2619 +static int
1.2620 +NamespaceChildrenCmd(dummy, interp, objc, objv)
1.2621 + ClientData dummy; /* Not used. */
1.2622 + Tcl_Interp *interp; /* Current interpreter. */
1.2623 + int objc; /* Number of arguments. */
1.2624 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2625 +{
1.2626 + Tcl_Namespace *namespacePtr;
1.2627 + Namespace *nsPtr, *childNsPtr;
1.2628 + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp);
1.2629 + char *pattern = NULL;
1.2630 + Tcl_DString buffer;
1.2631 + register Tcl_HashEntry *entryPtr;
1.2632 + Tcl_HashSearch search;
1.2633 + Tcl_Obj *listPtr, *elemPtr;
1.2634 +
1.2635 + /*
1.2636 + * Get a pointer to the specified namespace, or the current namespace.
1.2637 + */
1.2638 +
1.2639 + if (objc == 2) {
1.2640 + nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2641 + } else if ((objc == 3) || (objc == 4)) {
1.2642 + if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
1.2643 + return TCL_ERROR;
1.2644 + }
1.2645 + if (namespacePtr == NULL) {
1.2646 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2647 + "unknown namespace \"", Tcl_GetString(objv[2]),
1.2648 + "\" in namespace children command", (char *) NULL);
1.2649 + return TCL_ERROR;
1.2650 + }
1.2651 + nsPtr = (Namespace *) namespacePtr;
1.2652 + } else {
1.2653 + Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
1.2654 + return TCL_ERROR;
1.2655 + }
1.2656 +
1.2657 + /*
1.2658 + * Get the glob-style pattern, if any, used to narrow the search.
1.2659 + */
1.2660 +
1.2661 + Tcl_DStringInit(&buffer);
1.2662 + if (objc == 4) {
1.2663 + char *name = Tcl_GetString(objv[3]);
1.2664 +
1.2665 + if ((*name == ':') && (*(name+1) == ':')) {
1.2666 + pattern = name;
1.2667 + } else {
1.2668 + Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
1.2669 + if (nsPtr != globalNsPtr) {
1.2670 + Tcl_DStringAppend(&buffer, "::", 2);
1.2671 + }
1.2672 + Tcl_DStringAppend(&buffer, name, -1);
1.2673 + pattern = Tcl_DStringValue(&buffer);
1.2674 + }
1.2675 + }
1.2676 +
1.2677 + /*
1.2678 + * Create a list containing the full names of all child namespaces
1.2679 + * whose names match the specified pattern, if any.
1.2680 + */
1.2681 +
1.2682 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.2683 + entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
1.2684 + while (entryPtr != NULL) {
1.2685 + childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr);
1.2686 + if ((pattern == NULL)
1.2687 + || Tcl_StringMatch(childNsPtr->fullName, pattern)) {
1.2688 + elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
1.2689 + Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
1.2690 + }
1.2691 + entryPtr = Tcl_NextHashEntry(&search);
1.2692 + }
1.2693 +
1.2694 + Tcl_SetObjResult(interp, listPtr);
1.2695 + Tcl_DStringFree(&buffer);
1.2696 + return TCL_OK;
1.2697 +}
1.2698 +
1.2699 +/*
1.2700 + *----------------------------------------------------------------------
1.2701 + *
1.2702 + * NamespaceCodeCmd --
1.2703 + *
1.2704 + * Invoked to implement the "namespace code" command to capture the
1.2705 + * namespace context of a command. Handles the following syntax:
1.2706 + *
1.2707 + * namespace code arg
1.2708 + *
1.2709 + * Here "arg" can be a list. "namespace code arg" produces a result
1.2710 + * equivalent to that produced by the command
1.2711 + *
1.2712 + * list ::namespace inscope [namespace current] $arg
1.2713 + *
1.2714 + * However, if "arg" is itself a scoped value starting with
1.2715 + * "::namespace inscope", then the result is just "arg".
1.2716 + *
1.2717 + * Results:
1.2718 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.2719 + *
1.2720 + * Side effects:
1.2721 + * If anything goes wrong, this procedure returns an error
1.2722 + * message as the result in the interpreter's result object.
1.2723 + *
1.2724 + *----------------------------------------------------------------------
1.2725 + */
1.2726 +
1.2727 +static int
1.2728 +NamespaceCodeCmd(dummy, interp, objc, objv)
1.2729 + ClientData dummy; /* Not used. */
1.2730 + Tcl_Interp *interp; /* Current interpreter. */
1.2731 + int objc; /* Number of arguments. */
1.2732 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2733 +{
1.2734 + Namespace *currNsPtr;
1.2735 + Tcl_Obj *listPtr, *objPtr;
1.2736 + register char *arg, *p;
1.2737 + int length;
1.2738 +
1.2739 + if (objc != 3) {
1.2740 + Tcl_WrongNumArgs(interp, 2, objv, "arg");
1.2741 + return TCL_ERROR;
1.2742 + }
1.2743 +
1.2744 + /*
1.2745 + * If "arg" is already a scoped value, then return it directly.
1.2746 + */
1.2747 +
1.2748 + arg = Tcl_GetStringFromObj(objv[2], &length);
1.2749 + while (*arg == ':') {
1.2750 + arg++;
1.2751 + length--;
1.2752 + }
1.2753 + if ((*arg == 'n') && (length > 17)
1.2754 + && (strncmp(arg, "namespace", 9) == 0)) {
1.2755 + for (p = (arg + 9); (*p == ' '); p++) {
1.2756 + /* empty body: skip over spaces */
1.2757 + }
1.2758 + if ((*p == 'i') && ((p + 7) <= (arg + length))
1.2759 + && (strncmp(p, "inscope", 7) == 0)) {
1.2760 + Tcl_SetObjResult(interp, objv[2]);
1.2761 + return TCL_OK;
1.2762 + }
1.2763 + }
1.2764 +
1.2765 + /*
1.2766 + * Otherwise, construct a scoped command by building a list with
1.2767 + * "namespace inscope", the full name of the current namespace, and
1.2768 + * the argument "arg". By constructing a list, we ensure that scoped
1.2769 + * commands are interpreted properly when they are executed later,
1.2770 + * by the "namespace inscope" command.
1.2771 + */
1.2772 +
1.2773 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.2774 + Tcl_ListObjAppendElement(interp, listPtr,
1.2775 + Tcl_NewStringObj("::namespace", -1));
1.2776 + Tcl_ListObjAppendElement(interp, listPtr,
1.2777 + Tcl_NewStringObj("inscope", -1));
1.2778 +
1.2779 + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2780 + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
1.2781 + objPtr = Tcl_NewStringObj("::", -1);
1.2782 + } else {
1.2783 + objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
1.2784 + }
1.2785 + Tcl_ListObjAppendElement(interp, listPtr, objPtr);
1.2786 +
1.2787 + Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
1.2788 +
1.2789 + Tcl_SetObjResult(interp, listPtr);
1.2790 + return TCL_OK;
1.2791 +}
1.2792 +
1.2793 +/*
1.2794 + *----------------------------------------------------------------------
1.2795 + *
1.2796 + * NamespaceCurrentCmd --
1.2797 + *
1.2798 + * Invoked to implement the "namespace current" command which returns
1.2799 + * the fully-qualified name of the current namespace. Handles the
1.2800 + * following syntax:
1.2801 + *
1.2802 + * namespace current
1.2803 + *
1.2804 + * Results:
1.2805 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.2806 + *
1.2807 + * Side effects:
1.2808 + * Returns a result in the interpreter's result object. If anything
1.2809 + * goes wrong, the result is an error message.
1.2810 + *
1.2811 + *----------------------------------------------------------------------
1.2812 + */
1.2813 +
1.2814 +static int
1.2815 +NamespaceCurrentCmd(dummy, interp, objc, objv)
1.2816 + ClientData dummy; /* Not used. */
1.2817 + Tcl_Interp *interp; /* Current interpreter. */
1.2818 + int objc; /* Number of arguments. */
1.2819 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2820 +{
1.2821 + register Namespace *currNsPtr;
1.2822 +
1.2823 + if (objc != 2) {
1.2824 + Tcl_WrongNumArgs(interp, 2, objv, NULL);
1.2825 + return TCL_ERROR;
1.2826 + }
1.2827 +
1.2828 + /*
1.2829 + * The "real" name of the global namespace ("::") is the null string,
1.2830 + * but we return "::" for it as a convenience to programmers. Note that
1.2831 + * "" and "::" are treated as synonyms by the namespace code so that it
1.2832 + * is still easy to do things like:
1.2833 + *
1.2834 + * namespace [namespace current]::bar { ... }
1.2835 + */
1.2836 +
1.2837 + currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
1.2838 + if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) {
1.2839 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1);
1.2840 + } else {
1.2841 + Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1);
1.2842 + }
1.2843 + return TCL_OK;
1.2844 +}
1.2845 +
1.2846 +/*
1.2847 + *----------------------------------------------------------------------
1.2848 + *
1.2849 + * NamespaceDeleteCmd --
1.2850 + *
1.2851 + * Invoked to implement the "namespace delete" command to delete
1.2852 + * namespace(s). Handles the following syntax:
1.2853 + *
1.2854 + * namespace delete ?name name...?
1.2855 + *
1.2856 + * Each name identifies a namespace. It may include a sequence of
1.2857 + * namespace qualifiers separated by "::"s. If a namespace is found, it
1.2858 + * is deleted: all variables and procedures contained in that namespace
1.2859 + * are deleted. If that namespace is being used on the call stack, it
1.2860 + * is kept alive (but logically deleted) until it is removed from the
1.2861 + * call stack: that is, it can no longer be referenced by name but any
1.2862 + * currently executing procedure that refers to it is allowed to do so
1.2863 + * until the procedure returns. If the namespace can't be found, this
1.2864 + * procedure returns an error. If no namespaces are specified, this
1.2865 + * command does nothing.
1.2866 + *
1.2867 + * Results:
1.2868 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.2869 + *
1.2870 + * Side effects:
1.2871 + * Deletes the specified namespaces. If anything goes wrong, this
1.2872 + * procedure returns an error message in the interpreter's
1.2873 + * result object.
1.2874 + *
1.2875 + *----------------------------------------------------------------------
1.2876 + */
1.2877 +
1.2878 +static int
1.2879 +NamespaceDeleteCmd(dummy, interp, objc, objv)
1.2880 + ClientData dummy; /* Not used. */
1.2881 + Tcl_Interp *interp; /* Current interpreter. */
1.2882 + int objc; /* Number of arguments. */
1.2883 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2884 +{
1.2885 + Tcl_Namespace *namespacePtr;
1.2886 + char *name;
1.2887 + register int i;
1.2888 +
1.2889 + if (objc < 2) {
1.2890 + Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
1.2891 + return TCL_ERROR;
1.2892 + }
1.2893 +
1.2894 + /*
1.2895 + * Destroying one namespace may cause another to be destroyed. Break
1.2896 + * this into two passes: first check to make sure that all namespaces on
1.2897 + * the command line are valid, and report any errors.
1.2898 + */
1.2899 +
1.2900 + for (i = 2; i < objc; i++) {
1.2901 + name = Tcl_GetString(objv[i]);
1.2902 + namespacePtr = Tcl_FindNamespace(interp, name,
1.2903 + (Tcl_Namespace *) NULL, /*flags*/ 0);
1.2904 + if (namespacePtr == NULL) {
1.2905 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.2906 + "unknown namespace \"", Tcl_GetString(objv[i]),
1.2907 + "\" in namespace delete command", (char *) NULL);
1.2908 + return TCL_ERROR;
1.2909 + }
1.2910 + }
1.2911 +
1.2912 + /*
1.2913 + * Okay, now delete each namespace.
1.2914 + */
1.2915 +
1.2916 + for (i = 2; i < objc; i++) {
1.2917 + name = Tcl_GetString(objv[i]);
1.2918 + namespacePtr = Tcl_FindNamespace(interp, name,
1.2919 + (Tcl_Namespace *) NULL, /* flags */ 0);
1.2920 + if (namespacePtr) {
1.2921 + Tcl_DeleteNamespace(namespacePtr);
1.2922 + }
1.2923 + }
1.2924 + return TCL_OK;
1.2925 +}
1.2926 +
1.2927 +/*
1.2928 + *----------------------------------------------------------------------
1.2929 + *
1.2930 + * NamespaceEvalCmd --
1.2931 + *
1.2932 + * Invoked to implement the "namespace eval" command. Executes
1.2933 + * commands in a namespace. If the namespace does not already exist,
1.2934 + * it is created. Handles the following syntax:
1.2935 + *
1.2936 + * namespace eval name arg ?arg...?
1.2937 + *
1.2938 + * If more than one arg argument is specified, the command that is
1.2939 + * executed is the result of concatenating the arguments together with
1.2940 + * a space between each argument.
1.2941 + *
1.2942 + * Results:
1.2943 + * Returns TCL_OK if the namespace is found and the commands are
1.2944 + * executed successfully. Returns TCL_ERROR if anything goes wrong.
1.2945 + *
1.2946 + * Side effects:
1.2947 + * Returns the result of the command in the interpreter's result
1.2948 + * object. If anything goes wrong, this procedure returns an error
1.2949 + * message as the result.
1.2950 + *
1.2951 + *----------------------------------------------------------------------
1.2952 + */
1.2953 +
1.2954 +static int
1.2955 +NamespaceEvalCmd(dummy, interp, objc, objv)
1.2956 + ClientData dummy; /* Not used. */
1.2957 + Tcl_Interp *interp; /* Current interpreter. */
1.2958 + int objc; /* Number of arguments. */
1.2959 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.2960 +{
1.2961 + Tcl_Namespace *namespacePtr;
1.2962 + CallFrame frame;
1.2963 + Tcl_Obj *objPtr;
1.2964 + char *name;
1.2965 + int length, result;
1.2966 +
1.2967 + if (objc < 4) {
1.2968 + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
1.2969 + return TCL_ERROR;
1.2970 + }
1.2971 +
1.2972 + /*
1.2973 + * Try to resolve the namespace reference, caching the result in the
1.2974 + * namespace object along the way.
1.2975 + */
1.2976 +
1.2977 + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
1.2978 + if (result != TCL_OK) {
1.2979 + return result;
1.2980 + }
1.2981 +
1.2982 + /*
1.2983 + * If the namespace wasn't found, try to create it.
1.2984 + */
1.2985 +
1.2986 + if (namespacePtr == NULL) {
1.2987 + name = Tcl_GetStringFromObj(objv[2], &length);
1.2988 + namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL,
1.2989 + (Tcl_NamespaceDeleteProc *) NULL);
1.2990 + if (namespacePtr == NULL) {
1.2991 + return TCL_ERROR;
1.2992 + }
1.2993 + }
1.2994 +
1.2995 + /*
1.2996 + * Make the specified namespace the current namespace and evaluate
1.2997 + * the command(s).
1.2998 + */
1.2999 +
1.3000 + result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame,
1.3001 + namespacePtr, /*isProcCallFrame*/ 0);
1.3002 + if (result != TCL_OK) {
1.3003 + return TCL_ERROR;
1.3004 + }
1.3005 + frame.objc = objc;
1.3006 + frame.objv = objv; /* ref counts do not need to be incremented here */
1.3007 +
1.3008 + if (objc == 4) {
1.3009 +#ifndef TCL_TIP280
1.3010 + result = Tcl_EvalObjEx(interp, objv[3], 0);
1.3011 +#else
1.3012 + /* TIP #280 : Make invoker available to eval'd script */
1.3013 + Interp* iPtr = (Interp*) interp;
1.3014 + result = TclEvalObjEx(interp, objv[3], 0, iPtr->cmdFramePtr,3);
1.3015 +#endif
1.3016 + } else {
1.3017 + /*
1.3018 + * More than one argument: concatenate them together with spaces
1.3019 + * between, then evaluate the result. Tcl_EvalObjEx will delete
1.3020 + * the object when it decrements its refcount after eval'ing it.
1.3021 + */
1.3022 + objPtr = Tcl_ConcatObj(objc-3, objv+3);
1.3023 +#ifndef TCL_TIP280
1.3024 + result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT);
1.3025 +#else
1.3026 + /* TIP #280. Make invoking context available to eval'd script */
1.3027 + result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
1.3028 +#endif
1.3029 + }
1.3030 + if (result == TCL_ERROR) {
1.3031 + char msg[256 + TCL_INTEGER_SPACE];
1.3032 +
1.3033 + sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)",
1.3034 + namespacePtr->fullName, interp->errorLine);
1.3035 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.3036 + }
1.3037 +
1.3038 + /*
1.3039 + * Restore the previous "current" namespace.
1.3040 + */
1.3041 +
1.3042 + Tcl_PopCallFrame(interp);
1.3043 + return result;
1.3044 +}
1.3045 +
1.3046 +/*
1.3047 + *----------------------------------------------------------------------
1.3048 + *
1.3049 + * NamespaceExistsCmd --
1.3050 + *
1.3051 + * Invoked to implement the "namespace exists" command that returns
1.3052 + * true if the given namespace currently exists, and false otherwise.
1.3053 + * Handles the following syntax:
1.3054 + *
1.3055 + * namespace exists name
1.3056 + *
1.3057 + * Results:
1.3058 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3059 + *
1.3060 + * Side effects:
1.3061 + * Returns a result in the interpreter's result object. If anything
1.3062 + * goes wrong, the result is an error message.
1.3063 + *
1.3064 + *----------------------------------------------------------------------
1.3065 + */
1.3066 +
1.3067 +static int
1.3068 +NamespaceExistsCmd(dummy, interp, objc, objv)
1.3069 + ClientData dummy; /* Not used. */
1.3070 + Tcl_Interp *interp; /* Current interpreter. */
1.3071 + int objc; /* Number of arguments. */
1.3072 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3073 +{
1.3074 + Tcl_Namespace *namespacePtr;
1.3075 +
1.3076 + if (objc != 3) {
1.3077 + Tcl_WrongNumArgs(interp, 2, objv, "name");
1.3078 + return TCL_ERROR;
1.3079 + }
1.3080 +
1.3081 + /*
1.3082 + * Check whether the given namespace exists
1.3083 + */
1.3084 +
1.3085 + if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
1.3086 + return TCL_ERROR;
1.3087 + }
1.3088 +
1.3089 + Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL));
1.3090 + return TCL_OK;
1.3091 +}
1.3092 +
1.3093 +/*
1.3094 + *----------------------------------------------------------------------
1.3095 + *
1.3096 + * NamespaceExportCmd --
1.3097 + *
1.3098 + * Invoked to implement the "namespace export" command that specifies
1.3099 + * which commands are exported from a namespace. The exported commands
1.3100 + * are those that can be imported into another namespace using
1.3101 + * "namespace import". Both commands defined in a namespace and
1.3102 + * commands the namespace has imported can be exported by a
1.3103 + * namespace. This command has the following syntax:
1.3104 + *
1.3105 + * namespace export ?-clear? ?pattern pattern...?
1.3106 + *
1.3107 + * Each pattern may contain "string match"-style pattern matching
1.3108 + * special characters, but the pattern may not include any namespace
1.3109 + * qualifiers: that is, the pattern must specify commands in the
1.3110 + * current (exporting) namespace. The specified patterns are appended
1.3111 + * onto the namespace's list of export patterns.
1.3112 + *
1.3113 + * To reset the namespace's export pattern list, specify the "-clear"
1.3114 + * flag.
1.3115 + *
1.3116 + * If there are no export patterns and the "-clear" flag isn't given,
1.3117 + * this command returns the namespace's current export list.
1.3118 + *
1.3119 + * Results:
1.3120 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3121 + *
1.3122 + * Side effects:
1.3123 + * Returns a result in the interpreter's result object. If anything
1.3124 + * goes wrong, the result is an error message.
1.3125 + *
1.3126 + *----------------------------------------------------------------------
1.3127 + */
1.3128 +
1.3129 +static int
1.3130 +NamespaceExportCmd(dummy, interp, objc, objv)
1.3131 + ClientData dummy; /* Not used. */
1.3132 + Tcl_Interp *interp; /* Current interpreter. */
1.3133 + int objc; /* Number of arguments. */
1.3134 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3135 +{
1.3136 + Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp);
1.3137 + char *pattern, *string;
1.3138 + int resetListFirst = 0;
1.3139 + int firstArg, patternCt, i, result;
1.3140 +
1.3141 + if (objc < 2) {
1.3142 + Tcl_WrongNumArgs(interp, 2, objv,
1.3143 + "?-clear? ?pattern pattern...?");
1.3144 + return TCL_ERROR;
1.3145 + }
1.3146 +
1.3147 + /*
1.3148 + * Process the optional "-clear" argument.
1.3149 + */
1.3150 +
1.3151 + firstArg = 2;
1.3152 + if (firstArg < objc) {
1.3153 + string = Tcl_GetString(objv[firstArg]);
1.3154 + if (strcmp(string, "-clear") == 0) {
1.3155 + resetListFirst = 1;
1.3156 + firstArg++;
1.3157 + }
1.3158 + }
1.3159 +
1.3160 + /*
1.3161 + * If no pattern arguments are given, and "-clear" isn't specified,
1.3162 + * return the namespace's current export pattern list.
1.3163 + */
1.3164 +
1.3165 + patternCt = (objc - firstArg);
1.3166 + if (patternCt == 0) {
1.3167 + if (firstArg > 2) {
1.3168 + return TCL_OK;
1.3169 + } else { /* create list with export patterns */
1.3170 + Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.3171 + result = Tcl_AppendExportList(interp,
1.3172 + (Tcl_Namespace *) currNsPtr, listPtr);
1.3173 + if (result != TCL_OK) {
1.3174 + return result;
1.3175 + }
1.3176 + Tcl_SetObjResult(interp, listPtr);
1.3177 + return TCL_OK;
1.3178 + }
1.3179 + }
1.3180 +
1.3181 + /*
1.3182 + * Add each pattern to the namespace's export pattern list.
1.3183 + */
1.3184 +
1.3185 + for (i = firstArg; i < objc; i++) {
1.3186 + pattern = Tcl_GetString(objv[i]);
1.3187 + result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern,
1.3188 + ((i == firstArg)? resetListFirst : 0));
1.3189 + if (result != TCL_OK) {
1.3190 + return result;
1.3191 + }
1.3192 + }
1.3193 + return TCL_OK;
1.3194 +}
1.3195 +
1.3196 +/*
1.3197 + *----------------------------------------------------------------------
1.3198 + *
1.3199 + * NamespaceForgetCmd --
1.3200 + *
1.3201 + * Invoked to implement the "namespace forget" command to remove
1.3202 + * imported commands from a namespace. Handles the following syntax:
1.3203 + *
1.3204 + * namespace forget ?pattern pattern...?
1.3205 + *
1.3206 + * Each pattern is a name like "foo::*" or "a::b::x*". That is, the
1.3207 + * pattern may include the special pattern matching characters
1.3208 + * recognized by the "string match" command, but only in the command
1.3209 + * name at the end of the qualified name; the special pattern
1.3210 + * characters may not appear in a namespace name. All of the commands
1.3211 + * that match that pattern are checked to see if they have an imported
1.3212 + * command in the current namespace that refers to the matched
1.3213 + * command. If there is an alias, it is removed.
1.3214 + *
1.3215 + * Results:
1.3216 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3217 + *
1.3218 + * Side effects:
1.3219 + * Imported commands are removed from the current namespace. If
1.3220 + * anything goes wrong, this procedure returns an error message in the
1.3221 + * interpreter's result object.
1.3222 + *
1.3223 + *----------------------------------------------------------------------
1.3224 + */
1.3225 +
1.3226 +static int
1.3227 +NamespaceForgetCmd(dummy, interp, objc, objv)
1.3228 + ClientData dummy; /* Not used. */
1.3229 + Tcl_Interp *interp; /* Current interpreter. */
1.3230 + int objc; /* Number of arguments. */
1.3231 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3232 +{
1.3233 + char *pattern;
1.3234 + register int i, result;
1.3235 +
1.3236 + if (objc < 2) {
1.3237 + Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
1.3238 + return TCL_ERROR;
1.3239 + }
1.3240 +
1.3241 + for (i = 2; i < objc; i++) {
1.3242 + pattern = Tcl_GetString(objv[i]);
1.3243 + result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern);
1.3244 + if (result != TCL_OK) {
1.3245 + return result;
1.3246 + }
1.3247 + }
1.3248 + return TCL_OK;
1.3249 +}
1.3250 +
1.3251 +/*
1.3252 + *----------------------------------------------------------------------
1.3253 + *
1.3254 + * NamespaceImportCmd --
1.3255 + *
1.3256 + * Invoked to implement the "namespace import" command that imports
1.3257 + * commands into a namespace. Handles the following syntax:
1.3258 + *
1.3259 + * namespace import ?-force? ?pattern pattern...?
1.3260 + *
1.3261 + * Each pattern is a namespace-qualified name like "foo::*",
1.3262 + * "a::b::x*", or "bar::p". That is, the pattern may include the
1.3263 + * special pattern matching characters recognized by the "string match"
1.3264 + * command, but only in the command name at the end of the qualified
1.3265 + * name; the special pattern characters may not appear in a namespace
1.3266 + * name. All of the commands that match the pattern and which are
1.3267 + * exported from their namespace are made accessible from the current
1.3268 + * namespace context. This is done by creating a new "imported command"
1.3269 + * in the current namespace that points to the real command in its
1.3270 + * original namespace; when the imported command is called, it invokes
1.3271 + * the real command.
1.3272 + *
1.3273 + * If an imported command conflicts with an existing command, it is
1.3274 + * treated as an error. But if the "-force" option is included, then
1.3275 + * existing commands are overwritten by the imported commands.
1.3276 + *
1.3277 + * Results:
1.3278 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3279 + *
1.3280 + * Side effects:
1.3281 + * Adds imported commands to the current namespace. If anything goes
1.3282 + * wrong, this procedure returns an error message in the interpreter's
1.3283 + * result object.
1.3284 + *
1.3285 + *----------------------------------------------------------------------
1.3286 + */
1.3287 +
1.3288 +static int
1.3289 +NamespaceImportCmd(dummy, interp, objc, objv)
1.3290 + ClientData dummy; /* Not used. */
1.3291 + Tcl_Interp *interp; /* Current interpreter. */
1.3292 + int objc; /* Number of arguments. */
1.3293 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3294 +{
1.3295 + int allowOverwrite = 0;
1.3296 + char *string, *pattern;
1.3297 + register int i, result;
1.3298 + int firstArg;
1.3299 +
1.3300 + if (objc < 2) {
1.3301 + Tcl_WrongNumArgs(interp, 2, objv,
1.3302 + "?-force? ?pattern pattern...?");
1.3303 + return TCL_ERROR;
1.3304 + }
1.3305 +
1.3306 + /*
1.3307 + * Skip over the optional "-force" as the first argument.
1.3308 + */
1.3309 +
1.3310 + firstArg = 2;
1.3311 + if (firstArg < objc) {
1.3312 + string = Tcl_GetString(objv[firstArg]);
1.3313 + if ((*string == '-') && (strcmp(string, "-force") == 0)) {
1.3314 + allowOverwrite = 1;
1.3315 + firstArg++;
1.3316 + }
1.3317 + }
1.3318 +
1.3319 + /*
1.3320 + * Handle the imports for each of the patterns.
1.3321 + */
1.3322 +
1.3323 + for (i = firstArg; i < objc; i++) {
1.3324 + pattern = Tcl_GetString(objv[i]);
1.3325 + result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern,
1.3326 + allowOverwrite);
1.3327 + if (result != TCL_OK) {
1.3328 + return result;
1.3329 + }
1.3330 + }
1.3331 + return TCL_OK;
1.3332 +}
1.3333 +
1.3334 +/*
1.3335 + *----------------------------------------------------------------------
1.3336 + *
1.3337 + * NamespaceInscopeCmd --
1.3338 + *
1.3339 + * Invoked to implement the "namespace inscope" command that executes a
1.3340 + * script in the context of a particular namespace. This command is not
1.3341 + * expected to be used directly by programmers; calls to it are
1.3342 + * generated implicitly when programs use "namespace code" commands
1.3343 + * to register callback scripts. Handles the following syntax:
1.3344 + *
1.3345 + * namespace inscope name arg ?arg...?
1.3346 + *
1.3347 + * The "namespace inscope" command is much like the "namespace eval"
1.3348 + * command except that it has lappend semantics and the namespace must
1.3349 + * already exist. It treats the first argument as a list, and appends
1.3350 + * any arguments after the first onto the end as proper list elements.
1.3351 + * For example,
1.3352 + *
1.3353 + * namespace inscope ::foo a b c d
1.3354 + *
1.3355 + * is equivalent to
1.3356 + *
1.3357 + * namespace eval ::foo [concat a [list b c d]]
1.3358 + *
1.3359 + * This lappend semantics is important because many callback scripts
1.3360 + * are actually prefixes.
1.3361 + *
1.3362 + * Results:
1.3363 + * Returns TCL_OK to indicate success, or TCL_ERROR to indicate
1.3364 + * failure.
1.3365 + *
1.3366 + * Side effects:
1.3367 + * Returns a result in the Tcl interpreter's result object.
1.3368 + *
1.3369 + *----------------------------------------------------------------------
1.3370 + */
1.3371 +
1.3372 +static int
1.3373 +NamespaceInscopeCmd(dummy, interp, objc, objv)
1.3374 + ClientData dummy; /* Not used. */
1.3375 + Tcl_Interp *interp; /* Current interpreter. */
1.3376 + int objc; /* Number of arguments. */
1.3377 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3378 +{
1.3379 + Tcl_Namespace *namespacePtr;
1.3380 + Tcl_CallFrame frame;
1.3381 + int i, result;
1.3382 +
1.3383 + if (objc < 4) {
1.3384 + Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
1.3385 + return TCL_ERROR;
1.3386 + }
1.3387 +
1.3388 + /*
1.3389 + * Resolve the namespace reference.
1.3390 + */
1.3391 +
1.3392 + result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
1.3393 + if (result != TCL_OK) {
1.3394 + return result;
1.3395 + }
1.3396 + if (namespacePtr == NULL) {
1.3397 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.3398 + "unknown namespace \"", Tcl_GetString(objv[2]),
1.3399 + "\" in inscope namespace command", (char *) NULL);
1.3400 + return TCL_ERROR;
1.3401 + }
1.3402 +
1.3403 + /*
1.3404 + * Make the specified namespace the current namespace.
1.3405 + */
1.3406 +
1.3407 + result = Tcl_PushCallFrame(interp, &frame, namespacePtr,
1.3408 + /*isProcCallFrame*/ 0);
1.3409 + if (result != TCL_OK) {
1.3410 + return result;
1.3411 + }
1.3412 +
1.3413 + /*
1.3414 + * Execute the command. If there is just one argument, just treat it as
1.3415 + * a script and evaluate it. Otherwise, create a list from the arguments
1.3416 + * after the first one, then concatenate the first argument and the list
1.3417 + * of extra arguments to form the command to evaluate.
1.3418 + */
1.3419 +
1.3420 + if (objc == 4) {
1.3421 + result = Tcl_EvalObjEx(interp, objv[3], 0);
1.3422 + } else {
1.3423 + Tcl_Obj *concatObjv[2];
1.3424 + register Tcl_Obj *listPtr, *cmdObjPtr;
1.3425 +
1.3426 + listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
1.3427 + for (i = 4; i < objc; i++) {
1.3428 + result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]);
1.3429 + if (result != TCL_OK) {
1.3430 + Tcl_DecrRefCount(listPtr); /* free unneeded obj */
1.3431 + return result;
1.3432 + }
1.3433 + }
1.3434 +
1.3435 + concatObjv[0] = objv[3];
1.3436 + concatObjv[1] = listPtr;
1.3437 + cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
1.3438 + result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
1.3439 + Tcl_DecrRefCount(listPtr); /* we're done with the list object */
1.3440 + }
1.3441 + if (result == TCL_ERROR) {
1.3442 + char msg[256 + TCL_INTEGER_SPACE];
1.3443 +
1.3444 + sprintf(msg,
1.3445 + "\n (in namespace inscope \"%.200s\" script line %d)",
1.3446 + namespacePtr->fullName, interp->errorLine);
1.3447 + Tcl_AddObjErrorInfo(interp, msg, -1);
1.3448 + }
1.3449 +
1.3450 + /*
1.3451 + * Restore the previous "current" namespace.
1.3452 + */
1.3453 +
1.3454 + Tcl_PopCallFrame(interp);
1.3455 + return result;
1.3456 +}
1.3457 +
1.3458 +/*
1.3459 + *----------------------------------------------------------------------
1.3460 + *
1.3461 + * NamespaceOriginCmd --
1.3462 + *
1.3463 + * Invoked to implement the "namespace origin" command to return the
1.3464 + * fully-qualified name of the "real" command to which the specified
1.3465 + * "imported command" refers. Handles the following syntax:
1.3466 + *
1.3467 + * namespace origin name
1.3468 + *
1.3469 + * Results:
1.3470 + * An imported command is created in an namespace when that namespace
1.3471 + * imports a command from another namespace. If a command is imported
1.3472 + * into a sequence of namespaces a, b,...,n where each successive
1.3473 + * namespace just imports the command from the previous namespace, this
1.3474 + * command returns the fully-qualified name of the original command in
1.3475 + * the first namespace, a. If "name" does not refer to an alias, its
1.3476 + * fully-qualified name is returned. The returned name is stored in the
1.3477 + * interpreter's result object. This procedure returns TCL_OK if
1.3478 + * successful, and TCL_ERROR if anything goes wrong.
1.3479 + *
1.3480 + * Side effects:
1.3481 + * If anything goes wrong, this procedure returns an error message in
1.3482 + * the interpreter's result object.
1.3483 + *
1.3484 + *----------------------------------------------------------------------
1.3485 + */
1.3486 +
1.3487 +static int
1.3488 +NamespaceOriginCmd(dummy, interp, objc, objv)
1.3489 + ClientData dummy; /* Not used. */
1.3490 + Tcl_Interp *interp; /* Current interpreter. */
1.3491 + int objc; /* Number of arguments. */
1.3492 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3493 +{
1.3494 + Tcl_Command command, origCommand;
1.3495 +
1.3496 + if (objc != 3) {
1.3497 + Tcl_WrongNumArgs(interp, 2, objv, "name");
1.3498 + return TCL_ERROR;
1.3499 + }
1.3500 +
1.3501 + command = Tcl_GetCommandFromObj(interp, objv[2]);
1.3502 + if (command == (Tcl_Command) NULL) {
1.3503 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.3504 + "invalid command name \"", Tcl_GetString(objv[2]),
1.3505 + "\"", (char *) NULL);
1.3506 + return TCL_ERROR;
1.3507 + }
1.3508 + origCommand = TclGetOriginalCommand(command);
1.3509 + if (origCommand == (Tcl_Command) NULL) {
1.3510 + /*
1.3511 + * The specified command isn't an imported command. Return the
1.3512 + * command's name qualified by the full name of the namespace it
1.3513 + * was defined in.
1.3514 + */
1.3515 +
1.3516 + Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp));
1.3517 + } else {
1.3518 + Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp));
1.3519 + }
1.3520 + return TCL_OK;
1.3521 +}
1.3522 +
1.3523 +/*
1.3524 + *----------------------------------------------------------------------
1.3525 + *
1.3526 + * NamespaceParentCmd --
1.3527 + *
1.3528 + * Invoked to implement the "namespace parent" command that returns the
1.3529 + * fully-qualified name of the parent namespace for a specified
1.3530 + * namespace. Handles the following syntax:
1.3531 + *
1.3532 + * namespace parent ?name?
1.3533 + *
1.3534 + * Results:
1.3535 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3536 + *
1.3537 + * Side effects:
1.3538 + * Returns a result in the interpreter's result object. If anything
1.3539 + * goes wrong, the result is an error message.
1.3540 + *
1.3541 + *----------------------------------------------------------------------
1.3542 + */
1.3543 +
1.3544 +static int
1.3545 +NamespaceParentCmd(dummy, interp, objc, objv)
1.3546 + ClientData dummy; /* Not used. */
1.3547 + Tcl_Interp *interp; /* Current interpreter. */
1.3548 + int objc; /* Number of arguments. */
1.3549 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3550 +{
1.3551 + Tcl_Namespace *nsPtr;
1.3552 + int result;
1.3553 +
1.3554 + if (objc == 2) {
1.3555 + nsPtr = Tcl_GetCurrentNamespace(interp);
1.3556 + } else if (objc == 3) {
1.3557 + result = GetNamespaceFromObj(interp, objv[2], &nsPtr);
1.3558 + if (result != TCL_OK) {
1.3559 + return result;
1.3560 + }
1.3561 + if (nsPtr == NULL) {
1.3562 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.3563 + "unknown namespace \"", Tcl_GetString(objv[2]),
1.3564 + "\" in namespace parent command", (char *) NULL);
1.3565 + return TCL_ERROR;
1.3566 + }
1.3567 + } else {
1.3568 + Tcl_WrongNumArgs(interp, 2, objv, "?name?");
1.3569 + return TCL_ERROR;
1.3570 + }
1.3571 +
1.3572 + /*
1.3573 + * Report the parent of the specified namespace.
1.3574 + */
1.3575 +
1.3576 + if (nsPtr->parentPtr != NULL) {
1.3577 + Tcl_SetStringObj(Tcl_GetObjResult(interp),
1.3578 + nsPtr->parentPtr->fullName, -1);
1.3579 + }
1.3580 + return TCL_OK;
1.3581 +}
1.3582 +
1.3583 +/*
1.3584 + *----------------------------------------------------------------------
1.3585 + *
1.3586 + * NamespaceQualifiersCmd --
1.3587 + *
1.3588 + * Invoked to implement the "namespace qualifiers" command that returns
1.3589 + * any leading namespace qualifiers in a string. These qualifiers are
1.3590 + * namespace names separated by "::"s. For example, for "::foo::p" this
1.3591 + * command returns "::foo", and for "::" it returns "". This command
1.3592 + * is the complement of the "namespace tail" command. Note that this
1.3593 + * command does not check whether the "namespace" names are, in fact,
1.3594 + * the names of currently defined namespaces. Handles the following
1.3595 + * syntax:
1.3596 + *
1.3597 + * namespace qualifiers string
1.3598 + *
1.3599 + * Results:
1.3600 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3601 + *
1.3602 + * Side effects:
1.3603 + * Returns a result in the interpreter's result object. If anything
1.3604 + * goes wrong, the result is an error message.
1.3605 + *
1.3606 + *----------------------------------------------------------------------
1.3607 + */
1.3608 +
1.3609 +static int
1.3610 +NamespaceQualifiersCmd(dummy, interp, objc, objv)
1.3611 + ClientData dummy; /* Not used. */
1.3612 + Tcl_Interp *interp; /* Current interpreter. */
1.3613 + int objc; /* Number of arguments. */
1.3614 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3615 +{
1.3616 + register char *name, *p;
1.3617 + int length;
1.3618 +
1.3619 + if (objc != 3) {
1.3620 + Tcl_WrongNumArgs(interp, 2, objv, "string");
1.3621 + return TCL_ERROR;
1.3622 + }
1.3623 +
1.3624 + /*
1.3625 + * Find the end of the string, then work backward and find
1.3626 + * the start of the last "::" qualifier.
1.3627 + */
1.3628 +
1.3629 + name = Tcl_GetString(objv[2]);
1.3630 + for (p = name; *p != '\0'; p++) {
1.3631 + /* empty body */
1.3632 + }
1.3633 + while (--p >= name) {
1.3634 + if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
1.3635 + p -= 2; /* back up over the :: */
1.3636 + while ((p >= name) && (*p == ':')) {
1.3637 + p--; /* back up over the preceeding : */
1.3638 + }
1.3639 + break;
1.3640 + }
1.3641 + }
1.3642 +
1.3643 + if (p >= name) {
1.3644 + length = p-name+1;
1.3645 + Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length);
1.3646 + }
1.3647 + return TCL_OK;
1.3648 +}
1.3649 +
1.3650 +/*
1.3651 + *----------------------------------------------------------------------
1.3652 + *
1.3653 + * NamespaceTailCmd --
1.3654 + *
1.3655 + * Invoked to implement the "namespace tail" command that returns the
1.3656 + * trailing name at the end of a string with "::" namespace
1.3657 + * qualifiers. These qualifiers are namespace names separated by
1.3658 + * "::"s. For example, for "::foo::p" this command returns "p", and for
1.3659 + * "::" it returns "". This command is the complement of the "namespace
1.3660 + * qualifiers" command. Note that this command does not check whether
1.3661 + * the "namespace" names are, in fact, the names of currently defined
1.3662 + * namespaces. Handles the following syntax:
1.3663 + *
1.3664 + * namespace tail string
1.3665 + *
1.3666 + * Results:
1.3667 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3668 + *
1.3669 + * Side effects:
1.3670 + * Returns a result in the interpreter's result object. If anything
1.3671 + * goes wrong, the result is an error message.
1.3672 + *
1.3673 + *----------------------------------------------------------------------
1.3674 + */
1.3675 +
1.3676 +static int
1.3677 +NamespaceTailCmd(dummy, interp, objc, objv)
1.3678 + ClientData dummy; /* Not used. */
1.3679 + Tcl_Interp *interp; /* Current interpreter. */
1.3680 + int objc; /* Number of arguments. */
1.3681 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3682 +{
1.3683 + register char *name, *p;
1.3684 +
1.3685 + if (objc != 3) {
1.3686 + Tcl_WrongNumArgs(interp, 2, objv, "string");
1.3687 + return TCL_ERROR;
1.3688 + }
1.3689 +
1.3690 + /*
1.3691 + * Find the end of the string, then work backward and find the
1.3692 + * last "::" qualifier.
1.3693 + */
1.3694 +
1.3695 + name = Tcl_GetString(objv[2]);
1.3696 + for (p = name; *p != '\0'; p++) {
1.3697 + /* empty body */
1.3698 + }
1.3699 + while (--p > name) {
1.3700 + if ((*p == ':') && (*(p-1) == ':')) {
1.3701 + p++; /* just after the last "::" */
1.3702 + break;
1.3703 + }
1.3704 + }
1.3705 +
1.3706 + if (p >= name) {
1.3707 + Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1);
1.3708 + }
1.3709 + return TCL_OK;
1.3710 +}
1.3711 +
1.3712 +/*
1.3713 + *----------------------------------------------------------------------
1.3714 + *
1.3715 + * NamespaceWhichCmd --
1.3716 + *
1.3717 + * Invoked to implement the "namespace which" command that returns the
1.3718 + * fully-qualified name of a command or variable. If the specified
1.3719 + * command or variable does not exist, it returns "". Handles the
1.3720 + * following syntax:
1.3721 + *
1.3722 + * namespace which ?-command? ?-variable? name
1.3723 + *
1.3724 + * Results:
1.3725 + * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1.3726 + *
1.3727 + * Side effects:
1.3728 + * Returns a result in the interpreter's result object. If anything
1.3729 + * goes wrong, the result is an error message.
1.3730 + *
1.3731 + *----------------------------------------------------------------------
1.3732 + */
1.3733 +
1.3734 +static int
1.3735 +NamespaceWhichCmd(dummy, interp, objc, objv)
1.3736 + ClientData dummy; /* Not used. */
1.3737 + Tcl_Interp *interp; /* Current interpreter. */
1.3738 + int objc; /* Number of arguments. */
1.3739 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.3740 +{
1.3741 + register char *arg;
1.3742 + Tcl_Command cmd;
1.3743 + Tcl_Var variable;
1.3744 + int argIndex, lookup;
1.3745 +
1.3746 + if (objc < 3) {
1.3747 + badArgs:
1.3748 + Tcl_WrongNumArgs(interp, 2, objv,
1.3749 + "?-command? ?-variable? name");
1.3750 + return TCL_ERROR;
1.3751 + }
1.3752 +
1.3753 + /*
1.3754 + * Look for a flag controlling the lookup.
1.3755 + */
1.3756 +
1.3757 + argIndex = 2;
1.3758 + lookup = 0; /* assume command lookup by default */
1.3759 + arg = Tcl_GetString(objv[2]);
1.3760 + if (*arg == '-') {
1.3761 + if (strncmp(arg, "-command", 8) == 0) {
1.3762 + lookup = 0;
1.3763 + } else if (strncmp(arg, "-variable", 9) == 0) {
1.3764 + lookup = 1;
1.3765 + } else {
1.3766 + goto badArgs;
1.3767 + }
1.3768 + argIndex = 3;
1.3769 + }
1.3770 + if (objc != (argIndex + 1)) {
1.3771 + goto badArgs;
1.3772 + }
1.3773 +
1.3774 + switch (lookup) {
1.3775 + case 0: /* -command */
1.3776 + cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]);
1.3777 + if (cmd == (Tcl_Command) NULL) {
1.3778 + return TCL_OK; /* cmd not found, just return (no error) */
1.3779 + }
1.3780 + Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp));
1.3781 + break;
1.3782 +
1.3783 + case 1: /* -variable */
1.3784 + arg = Tcl_GetString(objv[argIndex]);
1.3785 + variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL,
1.3786 + /*flags*/ 0);
1.3787 + if (variable != (Tcl_Var) NULL) {
1.3788 + Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp));
1.3789 + }
1.3790 + break;
1.3791 + }
1.3792 + return TCL_OK;
1.3793 +}
1.3794 +
1.3795 +/*
1.3796 + *----------------------------------------------------------------------
1.3797 + *
1.3798 + * FreeNsNameInternalRep --
1.3799 + *
1.3800 + * Frees the resources associated with a nsName object's internal
1.3801 + * representation.
1.3802 + *
1.3803 + * Results:
1.3804 + * None.
1.3805 + *
1.3806 + * Side effects:
1.3807 + * Decrements the ref count of any Namespace structure pointed
1.3808 + * to by the nsName's internal representation. If there are no more
1.3809 + * references to the namespace, it's structure will be freed.
1.3810 + *
1.3811 + *----------------------------------------------------------------------
1.3812 + */
1.3813 +
1.3814 +static void
1.3815 +FreeNsNameInternalRep(objPtr)
1.3816 + register Tcl_Obj *objPtr; /* nsName object with internal
1.3817 + * representation to free */
1.3818 +{
1.3819 + register ResolvedNsName *resNamePtr =
1.3820 + (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
1.3821 + Namespace *nsPtr;
1.3822 +
1.3823 + /*
1.3824 + * Decrement the reference count of the namespace. If there are no
1.3825 + * more references, free it up.
1.3826 + */
1.3827 +
1.3828 + if (resNamePtr != NULL) {
1.3829 + resNamePtr->refCount--;
1.3830 + if (resNamePtr->refCount == 0) {
1.3831 +
1.3832 + /*
1.3833 + * Decrement the reference count for the cached namespace. If
1.3834 + * the namespace is dead, and there are no more references to
1.3835 + * it, free it.
1.3836 + */
1.3837 +
1.3838 + nsPtr = resNamePtr->nsPtr;
1.3839 + nsPtr->refCount--;
1.3840 + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
1.3841 + NamespaceFree(nsPtr);
1.3842 + }
1.3843 + ckfree((char *) resNamePtr);
1.3844 + }
1.3845 + }
1.3846 +}
1.3847 +
1.3848 +/*
1.3849 + *----------------------------------------------------------------------
1.3850 + *
1.3851 + * DupNsNameInternalRep --
1.3852 + *
1.3853 + * Initializes the internal representation of a nsName object to a copy
1.3854 + * of the internal representation of another nsName object.
1.3855 + *
1.3856 + * Results:
1.3857 + * None.
1.3858 + *
1.3859 + * Side effects:
1.3860 + * copyPtr's internal rep is set to refer to the same namespace
1.3861 + * referenced by srcPtr's internal rep. Increments the ref count of
1.3862 + * the ResolvedNsName structure used to hold the namespace reference.
1.3863 + *
1.3864 + *----------------------------------------------------------------------
1.3865 + */
1.3866 +
1.3867 +static void
1.3868 +DupNsNameInternalRep(srcPtr, copyPtr)
1.3869 + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
1.3870 + register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
1.3871 +{
1.3872 + register ResolvedNsName *resNamePtr =
1.3873 + (ResolvedNsName *) srcPtr->internalRep.otherValuePtr;
1.3874 +
1.3875 + copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
1.3876 + if (resNamePtr != NULL) {
1.3877 + resNamePtr->refCount++;
1.3878 + }
1.3879 + copyPtr->typePtr = &tclNsNameType;
1.3880 +}
1.3881 +
1.3882 +/*
1.3883 + *----------------------------------------------------------------------
1.3884 + *
1.3885 + * SetNsNameFromAny --
1.3886 + *
1.3887 + * Attempt to generate a nsName internal representation for a
1.3888 + * Tcl object.
1.3889 + *
1.3890 + * Results:
1.3891 + * Returns TCL_OK if the value could be converted to a proper
1.3892 + * namespace reference. Otherwise, it returns TCL_ERROR, along
1.3893 + * with an error message in the interpreter's result object.
1.3894 + *
1.3895 + * Side effects:
1.3896 + * If successful, the object is made a nsName object. Its internal rep
1.3897 + * is set to point to a ResolvedNsName, which contains a cached pointer
1.3898 + * to the Namespace. Reference counts are kept on both the
1.3899 + * ResolvedNsName and the Namespace, so we can keep track of their
1.3900 + * usage and free them when appropriate.
1.3901 + *
1.3902 + *----------------------------------------------------------------------
1.3903 + */
1.3904 +
1.3905 +static int
1.3906 +SetNsNameFromAny(interp, objPtr)
1.3907 + Tcl_Interp *interp; /* Points to the namespace in which to
1.3908 + * resolve name. Also used for error
1.3909 + * reporting if not NULL. */
1.3910 + register Tcl_Obj *objPtr; /* The object to convert. */
1.3911 +{
1.3912 + register Tcl_ObjType *oldTypePtr = objPtr->typePtr;
1.3913 + char *name;
1.3914 + CONST char *dummy;
1.3915 + Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
1.3916 + register ResolvedNsName *resNamePtr;
1.3917 +
1.3918 + /*
1.3919 + * Get the string representation. Make it up-to-date if necessary.
1.3920 + */
1.3921 +
1.3922 + name = objPtr->bytes;
1.3923 + if (name == NULL) {
1.3924 + name = Tcl_GetString(objPtr);
1.3925 + }
1.3926 +
1.3927 + /*
1.3928 + * Look for the namespace "name" in the current namespace. If there is
1.3929 + * an error parsing the (possibly qualified) name, return an error.
1.3930 + * If the namespace isn't found, we convert the object to an nsName
1.3931 + * object with a NULL ResolvedNsName* internal rep.
1.3932 + */
1.3933 +
1.3934 + TclGetNamespaceForQualName(interp, name, (Namespace *) NULL,
1.3935 + FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
1.3936 +
1.3937 + /*
1.3938 + * If we found a namespace, then create a new ResolvedNsName structure
1.3939 + * that holds a reference to it.
1.3940 + */
1.3941 +
1.3942 + if (nsPtr != NULL) {
1.3943 + Namespace *currNsPtr =
1.3944 + (Namespace *) Tcl_GetCurrentNamespace(interp);
1.3945 +
1.3946 + nsPtr->refCount++;
1.3947 + resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
1.3948 + resNamePtr->nsPtr = nsPtr;
1.3949 + resNamePtr->nsId = nsPtr->nsId;
1.3950 + resNamePtr->refNsPtr = currNsPtr;
1.3951 + resNamePtr->refCount = 1;
1.3952 + } else {
1.3953 + resNamePtr = NULL;
1.3954 + }
1.3955 +
1.3956 + /*
1.3957 + * Free the old internalRep before setting the new one.
1.3958 + * We do this as late as possible to allow the conversion code
1.3959 + * (in particular, Tcl_GetStringFromObj) to use that old internalRep.
1.3960 + */
1.3961 +
1.3962 + if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
1.3963 + oldTypePtr->freeIntRepProc(objPtr);
1.3964 + }
1.3965 +
1.3966 + objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr;
1.3967 + objPtr->typePtr = &tclNsNameType;
1.3968 + return TCL_OK;
1.3969 +}
1.3970 +
1.3971 +/*
1.3972 + *----------------------------------------------------------------------
1.3973 + *
1.3974 + * UpdateStringOfNsName --
1.3975 + *
1.3976 + * Updates the string representation for a nsName object.
1.3977 + * Note: This procedure does not free an existing old string rep
1.3978 + * so storage will be lost if this has not already been done.
1.3979 + *
1.3980 + * Results:
1.3981 + * None.
1.3982 + *
1.3983 + * Side effects:
1.3984 + * The object's string is set to a copy of the fully qualified
1.3985 + * namespace name.
1.3986 + *
1.3987 + *----------------------------------------------------------------------
1.3988 + */
1.3989 +
1.3990 +static void
1.3991 +UpdateStringOfNsName(objPtr)
1.3992 + register Tcl_Obj *objPtr; /* nsName object with string rep to update. */
1.3993 +{
1.3994 + ResolvedNsName *resNamePtr =
1.3995 + (ResolvedNsName *) objPtr->internalRep.otherValuePtr;
1.3996 + register Namespace *nsPtr;
1.3997 + char *name = "";
1.3998 + int length;
1.3999 +
1.4000 + if ((resNamePtr != NULL)
1.4001 + && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) {
1.4002 + nsPtr = resNamePtr->nsPtr;
1.4003 + if (nsPtr->flags & NS_DEAD) {
1.4004 + nsPtr = NULL;
1.4005 + }
1.4006 + if (nsPtr != NULL) {
1.4007 + name = nsPtr->fullName;
1.4008 + }
1.4009 + }
1.4010 +
1.4011 + /*
1.4012 + * The following sets the string rep to an empty string on the heap
1.4013 + * if the internal rep is NULL.
1.4014 + */
1.4015 +
1.4016 + length = strlen(name);
1.4017 + if (length == 0) {
1.4018 + objPtr->bytes = tclEmptyStringRep;
1.4019 + } else {
1.4020 + objPtr->bytes = (char *) ckalloc((unsigned) (length + 1));
1.4021 + memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length);
1.4022 + objPtr->bytes[length] = '\0';
1.4023 + }
1.4024 + objPtr->length = length;
1.4025 +}