util/src/TclTk/tcl8.6.12/generic/tclNamesp.c

   1 /*
   2  * tclNamesp.c --
   3  *
   4  *      Contains support for namespaces, which provide a separate context of
   5  *      commands and global variables. The global :: namespace is the
   6  *      traditional Tcl "global" scope. Other namespaces are created as
   7  *      children of the global namespace. These other namespaces contain
   8  *      special-purpose commands and variables for packages.
   9  *
  10  * Copyright (c) 1993-1997 Lucent Technologies.
  11  * Copyright (c) 1997 Sun Microsystems, Inc.
  12  * Copyright (c) 1998-1999 by Scriptics Corporation.
  13  * Copyright (c) 2002-2005 Donal K. Fellows.
  14  * Copyright (c) 2006 Neil Madden.
  15  * Contributions from Don Porter, NIST, 2007. (not subject to US copyright)
  16  *
  17  * Originally implemented by
  18  *   Michael J. McLennan
  19  *   Bell Labs Innovations for Lucent Technologies
  20  *   mmclennan@lucent.com
  21  *
  22  * See the file "license.terms" for information on usage and redistribution of
  23  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  24  */
  25
  26 #include "tclInt.h"
  27 #include "tclCompile.h" /* for TclLogCommandInfo visibility */
  28
  29 /*
  30  * Thread-local storage used to avoid having a global lock on data that is not
  31  * limited to a single interpreter.
  32  */
  33
  34 typedef struct ThreadSpecificData {
  35     long numNsCreated;          /* Count of the number of namespaces created
  36                                  * within the thread. This value is used as a
  37                                  * unique id for each namespace. Cannot be
  38                                  * per-interp because the nsId is used to
  39                                  * distinguish objects which can be passed
  40                                  * around between interps in the same thread,
  41                                  * but does not need to be global because
  42                                  * object internal reps are always per-thread
  43                                  * anyway. */
  44 } ThreadSpecificData;
  45
  46 static Tcl_ThreadDataKey dataKey;
  47
  48 /*
  49  * This structure contains a cached pointer to a namespace that is the result
  50  * of resolving the namespace's name in some other namespace. It is the
  51  * internal representation for a nsName object. It contains the pointer along
  52  * with some information that is used to check the cached pointer's validity.
  53  */
  54
  55 typedef struct ResolvedNsName {
  56     Namespace *nsPtr;           /* A cached pointer to the Namespace that the
  57                                  * name resolved to. */
  58     Namespace *refNsPtr;        /* Points to the namespace context in which
  59                                  * the name was resolved. NULL if the name is
  60                                  * fully qualified and thus the resolution
  61                                  * does not depend on the context. */
  62     int refCount;               /* Reference count: 1 for each nsName object
  63                                  * that has a pointer to this ResolvedNsName
  64                                  * structure as its internal rep. This
  65                                  * structure can be freed when refCount
  66                                  * becomes zero. */
  67 } ResolvedNsName;
  68
  69 /*
  70  * Declarations for functions local to this file:
  71  */
  72
  73 static void             DeleteImportedCmd(ClientData clientData);
  74 static int              DoImport(Tcl_Interp *interp,
  75                             Namespace *nsPtr, Tcl_HashEntry *hPtr,
  76                             const char *cmdName, const char *pattern,
  77                             Namespace *importNsPtr, int allowOverwrite);
  78 static void             DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr);
  79 static char *           ErrorCodeRead(ClientData clientData,Tcl_Interp *interp,
  80                             const char *name1, const char *name2, int flags);
  81 static char *           ErrorInfoRead(ClientData clientData,Tcl_Interp *interp,
  82                             const char *name1, const char *name2, int flags);
  83 static char *           EstablishErrorCodeTraces(ClientData clientData,
  84                             Tcl_Interp *interp, const char *name1,
  85                             const char *name2, int flags);
  86 static char *           EstablishErrorInfoTraces(ClientData clientData,
  87                             Tcl_Interp *interp, const char *name1,
  88                             const char *name2, int flags);
  89 static void             FreeNsNameInternalRep(Tcl_Obj *objPtr);
  90 static int              GetNamespaceFromObj(Tcl_Interp *interp,
  91                             Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
  92 static int              InvokeImportedCmd(ClientData clientData,
  93                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
  94 static int              InvokeImportedNRCmd(ClientData clientData,
  95                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
  96 static int              NamespaceChildrenCmd(ClientData dummy,
  97                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
  98 static int              NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
  99                             int objc, Tcl_Obj *const objv[]);
 100 static int              NamespaceCurrentCmd(ClientData dummy,
 101                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 102 static int              NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
 103                             int objc, Tcl_Obj *const objv[]);
 104 static int              NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
 105                             int objc, Tcl_Obj *const objv[]);
 106 static int              NRNamespaceEvalCmd(ClientData dummy,
 107                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 108 static int              NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
 109                             int objc, Tcl_Obj *const objv[]);
 110 static int              NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
 111                             int objc, Tcl_Obj *const objv[]);
 112 static int              NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
 113                             int objc, Tcl_Obj *const objv[]);
 114 static void             NamespaceFree(Namespace *nsPtr);
 115 static int              NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
 116                             int objc, Tcl_Obj *const objv[]);
 117 static int              NamespaceInscopeCmd(ClientData dummy,
 118                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 119 static int              NRNamespaceInscopeCmd(ClientData dummy,
 120                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 121 static int              NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
 122                             int objc, Tcl_Obj *const objv[]);
 123 static int              NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
 124                             int objc, Tcl_Obj *const objv[]);
 125 static int              NamespacePathCmd(ClientData dummy, Tcl_Interp *interp,
 126                             int objc, Tcl_Obj *const objv[]);
 127 static int              NamespaceQualifiersCmd(ClientData dummy,
 128                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 129 static int              NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
 130                             int objc, Tcl_Obj *const objv[]);
 131 static int              NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
 132                             int objc, Tcl_Obj *const objv[]);
 133 static int              NamespaceUnknownCmd(ClientData dummy,
 134                             Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 135 static int              NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
 136                             int objc, Tcl_Obj *const objv[]);
 137 static int              SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 138 static void             UnlinkNsPath(Namespace *nsPtr);
 139
 140 static Tcl_NRPostProc NsEval_Callback;
 141
 142 /*
 143  * This structure defines a Tcl object type that contains a namespace
 144  * reference. It is used in commands that take the name of a namespace as an
 145  * argument. The namespace reference is resolved, and the result in cached in
 146  * the object.
 147  */
 148
 149 static const Tcl_ObjType nsNameType = {
 150     "nsName",                   /* the type's name */
 151     FreeNsNameInternalRep,      /* freeIntRepProc */
 152     DupNsNameInternalRep,       /* dupIntRepProc */
 153     NULL,                       /* updateStringProc */
 154     SetNsNameFromAny            /* setFromAnyProc */
 155 };
 156
 157 /*
 158  * Array of values describing how to implement each standard subcommand of the
 159  * "namespace" command.
 160  */
 161
 162 static const EnsembleImplMap defaultNamespaceMap[] = {
 163     {"children",   NamespaceChildrenCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0},
 164     {"code",       NamespaceCodeCmd,    TclCompileNamespaceCodeCmd, NULL, NULL, 0},
 165     {"current",    NamespaceCurrentCmd, TclCompileNamespaceCurrentCmd, NULL, NULL, 0},
 166     {"delete",     NamespaceDeleteCmd,  TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
 167     {"ensemble",   TclNamespaceEnsembleCmd, NULL, NULL, NULL, 0},
 168     {"eval",       NamespaceEvalCmd,    NULL, NRNamespaceEvalCmd, NULL, 0},
 169     {"exists",     NamespaceExistsCmd,  TclCompileBasic1ArgCmd, NULL, NULL, 0},
 170     {"export",     NamespaceExportCmd,  TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
 171     {"forget",     NamespaceForgetCmd,  TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
 172     {"import",     NamespaceImportCmd,  TclCompileBasicMin0ArgCmd, NULL, NULL, 0},
 173     {"inscope",    NamespaceInscopeCmd, NULL, NRNamespaceInscopeCmd, NULL, 0},
 174     {"origin",     NamespaceOriginCmd,  TclCompileNamespaceOriginCmd, NULL, NULL, 0},
 175     {"parent",     NamespaceParentCmd,  TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
 176     {"path",       NamespacePathCmd,    TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
 177     {"qualifiers", NamespaceQualifiersCmd, TclCompileNamespaceQualifiersCmd, NULL, NULL, 0},
 178     {"tail",       NamespaceTailCmd,    TclCompileNamespaceTailCmd, NULL, NULL, 0},
 179     {"unknown",    NamespaceUnknownCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
 180     {"upvar",      NamespaceUpvarCmd,   TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
 181     {"which",      NamespaceWhichCmd,   TclCompileNamespaceWhichCmd, NULL, NULL, 0},
 182     {NULL, NULL, NULL, NULL, NULL, 0}
 183 };
 184 \f
 185 /*
 186  *----------------------------------------------------------------------
 187  *
 188  * TclInitNamespaceSubsystem --
 189  *
 190  *      This function is called to initialize all the structures that are used
 191  *      by namespaces on a per-process basis.
 192  *
 193  * Results:
 194  *      None.
 195  *
 196  * Side effects:
 197  *      None.
 198  *
 199  *----------------------------------------------------------------------
 200  */
 201
 202 void
 203 TclInitNamespaceSubsystem(void)
 204 {
 205     /*
 206      * Does nothing for now.
 207      */
 208 }
 209 \f
 210 /*
 211  *----------------------------------------------------------------------
 212  *
 213  * Tcl_GetCurrentNamespace --
 214  *
 215  *      Returns a pointer to an interpreter's currently active namespace.
 216  *
 217  * Results:
 218  *      Returns a pointer to the interpreter's current namespace.
 219  *
 220  * Side effects:
 221  *      None.
 222  *
 223  *----------------------------------------------------------------------
 224  */
 225
 226 Tcl_Namespace *
 227 Tcl_GetCurrentNamespace(
 228     Tcl_Interp *interp)/* Interpreter whose current namespace is
 229                                  * being queried. */
 230 {
 231     return TclGetCurrentNamespace(interp);
 232 }
 233 \f
 234 /*
 235  *----------------------------------------------------------------------
 236  *
 237  * Tcl_GetGlobalNamespace --
 238  *
 239  *      Returns a pointer to an interpreter's global :: namespace.
 240  *
 241  * Results:
 242  *      Returns a pointer to the specified interpreter's global namespace.
 243  *
 244  * Side effects:
 245  *      None.
 246  *
 247  *----------------------------------------------------------------------
 248  */
 249
 250 Tcl_Namespace *
 251 Tcl_GetGlobalNamespace(
 252     Tcl_Interp *interp)/* Interpreter whose global namespace should
 253                                  * be returned. */
 254 {
 255     return TclGetGlobalNamespace(interp);
 256 }
 257 \f
 258 /*
 259  *----------------------------------------------------------------------
 260  *
 261  * Tcl_PushCallFrame --
 262  *
 263  *      Pushes a new call frame onto the interpreter's Tcl call stack. Called
 264  *      when executing a Tcl procedure or a "namespace eval" or "namespace
 265  *      inscope" command.
 266  *
 267  * Results:
 268  *      Returns TCL_OK if successful, or TCL_ERROR (along with an error
 269  *      message in the interpreter's result object) if something goes wrong.
 270  *
 271  * Side effects:
 272  *      Modifies the interpreter's Tcl call stack.
 273  *
 274  *----------------------------------------------------------------------
 275  */
 276
 277 int
 278 Tcl_PushCallFrame(
 279     Tcl_Interp *interp,         /* Interpreter in which the new call frame is
 280                                  * to be pushed. */
 281     Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push.
 282                                  * Storage for this has already been allocated
 283                                  * by the caller; typically this is the
 284                                  * address of a CallFrame structure allocated
 285                                  * on the caller's C stack. The call frame
 286                                  * will be initialized by this function. The
 287                                  * caller can pop the frame later with
 288                                  * Tcl_PopCallFrame, and it is responsible for
 289                                  * freeing the frame's storage. */
 290     Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
 291                                  * will execute. If NULL, the interpreter's
 292                                  * current namespace will be used. */
 293     int isProcCallFrame)        /* If nonzero, the frame represents a called
 294                                  * Tcl procedure and may have local vars. Vars
 295                                  * will ordinarily be looked up in the frame.
 296                                  * If new variables are created, they will be
 297                                  * created in the frame. If 0, the frame is
 298                                  * for a "namespace eval" or "namespace
 299                                  * inscope" command and var references are
 300                                  * treated as references to namespace
 301                                  * variables. */
 302 {
 303     Interp *iPtr = (Interp *) interp;
 304     CallFrame *framePtr = (CallFrame *) callFramePtr;
 305     Namespace *nsPtr;
 306
 307     if (namespacePtr == NULL) {
 308         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
 309     } else {
 310         nsPtr = (Namespace *) namespacePtr;
 311
 312         /*
 313          * TODO: Examine whether it would be better to guard based on NS_DYING
 314          * or NS_KILLED. It appears that these are not tested because they can
 315          * be set in a global interp that has been [namespace delete]d, but
 316          * which never really completely goes away because of lingering global
 317          * things like ::errorInfo and [::unknown] and hidden commands.
 318          * Review of those designs might permit stricter checking here.
 319          */
 320
 321         if (nsPtr->flags & NS_DEAD) {
 322             Tcl_Panic("Trying to push call frame for dead namespace");
 323             /*NOTREACHED*/
 324         }
 325     }
 326
 327     nsPtr->activationCount++;
 328     framePtr->nsPtr = nsPtr;
 329     framePtr->isProcCallFrame = isProcCallFrame;
 330     framePtr->objc = 0;
 331     framePtr->objv = NULL;
 332     framePtr->callerPtr = iPtr->framePtr;
 333     framePtr->callerVarPtr = iPtr->varFramePtr;
 334     if (iPtr->varFramePtr != NULL) {
 335         framePtr->level = (iPtr->varFramePtr->level + 1);
 336     } else {
 337         framePtr->level = 0;
 338     }
 339     framePtr->procPtr = NULL;           /* no called procedure */
 340     framePtr->varTablePtr = NULL;       /* and no local variables */
 341     framePtr->numCompiledLocals = 0;
 342     framePtr->compiledLocals = NULL;
 343     framePtr->clientData = NULL;
 344     framePtr->localCachePtr = NULL;
 345     framePtr->tailcallPtr = NULL;
 346
 347     /*
 348      * Push the new call frame onto the interpreter's stack of procedure call
 349      * frames making it the current frame.
 350      */
 351
 352     iPtr->framePtr = framePtr;
 353     iPtr->varFramePtr = framePtr;
 354
 355     return TCL_OK;
 356 }
 357 \f
 358 /*
 359  *----------------------------------------------------------------------
 360  *
 361  * Tcl_PopCallFrame --
 362  *
 363  *      Removes a call frame from the Tcl call stack for the interpreter.
 364  *      Called to remove a frame previously pushed by Tcl_PushCallFrame.
 365  *
 366  * Results:
 367  *      None.
 368  *
 369  * Side effects:
 370  *      Modifies the call stack of the interpreter. Resets various fields of
 371  *      the popped call frame. If a namespace has been deleted and has no more
 372  *      activations on the call stack, the namespace is destroyed.
 373  *
 374  *----------------------------------------------------------------------
 375  */
 376
 377 void
 378 Tcl_PopCallFrame(
 379     Tcl_Interp *interp)         /* Interpreter with call frame to pop. */
 380 {
 381     Interp *iPtr = (Interp *) interp;
 382     CallFrame *framePtr = iPtr->framePtr;
 383     Namespace *nsPtr;
 384
 385     /*
 386      * It's important to remove the call frame from the interpreter's stack of
 387      * call frames before deleting local variables, so that traces invoked by
 388      * the variable deletion don't see the partially-deleted frame.
 389      */
 390
 391     if (framePtr->callerPtr) {
 392         iPtr->framePtr = framePtr->callerPtr;
 393         iPtr->varFramePtr = framePtr->callerVarPtr;
 394     } else {
 395         /* Tcl_PopCallFrame: trying to pop rootCallFrame! */
 396     }
 397
 398     if (framePtr->varTablePtr != NULL) {
 399         TclDeleteVars(iPtr, framePtr->varTablePtr);
 400         ckfree(framePtr->varTablePtr);
 401         framePtr->varTablePtr = NULL;
 402     }
 403     if (framePtr->numCompiledLocals > 0) {
 404         TclDeleteCompiledLocalVars(iPtr, framePtr);
 405         if (--framePtr->localCachePtr->refCount == 0) {
 406             TclFreeLocalCache(interp, framePtr->localCachePtr);
 407         }
 408         framePtr->localCachePtr = NULL;
 409     }
 410
 411     /*
 412      * Decrement the namespace's count of active call frames. If the namespace
 413      * is "dying" and there are no more active call frames, call
 414      * Tcl_DeleteNamespace to destroy it.
 415      */
 416
 417     nsPtr = framePtr->nsPtr;
 418     nsPtr->activationCount--;
 419     if ((nsPtr->flags & NS_DYING)
 420             && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
 421         Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
 422     }
 423     framePtr->nsPtr = NULL;
 424
 425     if (framePtr->tailcallPtr) {
 426         TclSetTailcall(interp, framePtr->tailcallPtr);
 427     }
 428 }
 429 \f
 430 /*
 431  *----------------------------------------------------------------------
 432  *
 433  * TclPushStackFrame --
 434  *
 435  *      Allocates a new call frame in the interpreter's execution stack, then
 436  *      pushes it onto the interpreter's Tcl call stack. Called when executing
 437  *      a Tcl procedure or a "namespace eval" or "namespace inscope" command.
 438  *
 439  * Results:
 440  *      Returns TCL_OK if successful, or TCL_ERROR (along with an error
 441  *      message in the interpreter's result object) if something goes wrong.
 442  *
 443  * Side effects:
 444  *      Modifies the interpreter's Tcl call stack.
 445  *
 446  *----------------------------------------------------------------------
 447  */
 448
 449 int
 450 TclPushStackFrame(
 451     Tcl_Interp *interp,         /* Interpreter in which the new call frame is
 452                                  * to be pushed. */
 453     Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack
 454                                  * allocated call frame. */
 455     Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
 456                                  * will execute. If NULL, the interpreter's
 457                                  * current namespace will be used. */
 458     int isProcCallFrame)        /* If nonzero, the frame represents a called
 459                                  * Tcl procedure and may have local vars. Vars
 460                                  * will ordinarily be looked up in the frame.
 461                                  * If new variables are created, they will be
 462                                  * created in the frame. If 0, the frame is
 463                                  * for a "namespace eval" or "namespace
 464                                  * inscope" command and var references are
 465                                  * treated as references to namespace
 466                                  * variables. */
 467 {
 468     *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame));
 469     return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
 470             isProcCallFrame);
 471 }
 472
 473 void
 474 TclPopStackFrame(
 475     Tcl_Interp *interp)         /* Interpreter with call frame to pop. */
 476 {
 477     CallFrame *freePtr = ((Interp *) interp)->framePtr;
 478
 479     Tcl_PopCallFrame(interp);
 480     TclStackFree(interp, freePtr);
 481 }
 482 \f
 483 /*
 484  *----------------------------------------------------------------------
 485  *
 486  * EstablishErrorCodeTraces --
 487  *
 488  *      Creates traces on the ::errorCode variable to keep its value
 489  *      consistent with the expectations of legacy code.
 490  *
 491  * Results:
 492  *      None.
 493  *
 494  * Side effects:
 495  *      Read and unset traces are established on ::errorCode.
 496  *
 497  *----------------------------------------------------------------------
 498  */
 499
 500 static char *
 501 EstablishErrorCodeTraces(
 502     ClientData clientData,
 503     Tcl_Interp *interp,
 504     const char *name1,
 505     const char *name2,
 506     int flags)
 507 {
 508     Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
 509             ErrorCodeRead, NULL);
 510     Tcl_TraceVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
 511             EstablishErrorCodeTraces, NULL);
 512     return NULL;
 513 }
 514 \f
 515 /*
 516  *----------------------------------------------------------------------
 517  *
 518  * ErrorCodeRead --
 519  *
 520  *      Called when the ::errorCode variable is read. Copies the current value
 521  *      of the interp's errorCode field into ::errorCode.
 522  *
 523  * Results:
 524  *      None.
 525  *
 526  * Side effects:
 527  *      None.
 528  *
 529  *----------------------------------------------------------------------
 530  */
 531
 532 static char *
 533 ErrorCodeRead(
 534     ClientData clientData,
 535     Tcl_Interp *interp,
 536     const char *name1,
 537     const char *name2,
 538     int flags)
 539 {
 540     Interp *iPtr = (Interp *) interp;
 541
 542     if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
 543         return NULL;
 544     }
 545     if (iPtr->errorCode) {
 546         Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
 547                 iPtr->errorCode, TCL_GLOBAL_ONLY);
 548         return NULL;
 549     }
 550     if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) {
 551         Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
 552                 Tcl_NewObj(), TCL_GLOBAL_ONLY);
 553     }
 554     return NULL;
 555 }
 556 \f
 557 /*
 558  *----------------------------------------------------------------------
 559  *
 560  * EstablishErrorInfoTraces --
 561  *
 562  *      Creates traces on the ::errorInfo variable to keep its value
 563  *      consistent with the expectations of legacy code.
 564  *
 565  * Results:
 566  *      None.
 567  *
 568  * Side effects:
 569  *      Read and unset traces are established on ::errorInfo.
 570  *
 571  *----------------------------------------------------------------------
 572  */
 573
 574 static char *
 575 EstablishErrorInfoTraces(
 576     ClientData clientData,
 577     Tcl_Interp *interp,
 578     const char *name1,
 579     const char *name2,
 580     int flags)
 581 {
 582     Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS,
 583             ErrorInfoRead, NULL);
 584     Tcl_TraceVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_UNSETS,
 585             EstablishErrorInfoTraces, NULL);
 586     return NULL;
 587 }
 588 \f
 589 /*
 590  *----------------------------------------------------------------------
 591  *
 592  * ErrorInfoRead --
 593  *
 594  *      Called when the ::errorInfo variable is read. Copies the current value
 595  *      of the interp's errorInfo field into ::errorInfo.
 596  *
 597  * Results:
 598  *      None.
 599  *
 600  * Side effects:
 601  *      None.
 602  *
 603  *----------------------------------------------------------------------
 604  */
 605
 606 static char *
 607 ErrorInfoRead(
 608     ClientData clientData,
 609     Tcl_Interp *interp,
 610     const char *name1,
 611     const char *name2,
 612     int flags)
 613 {
 614     Interp *iPtr = (Interp *) interp;
 615
 616     if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
 617         return NULL;
 618     }
 619     if (iPtr->errorInfo) {
 620         Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
 621                 iPtr->errorInfo, TCL_GLOBAL_ONLY);
 622         return NULL;
 623     }
 624     if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) {
 625         Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
 626                 Tcl_NewObj(), TCL_GLOBAL_ONLY);
 627     }
 628     return NULL;
 629 }
 630 \f
 631 /*
 632  *----------------------------------------------------------------------
 633  *
 634  * Tcl_CreateNamespace --
 635  *
 636  *      Creates a new namespace with the given name. If there is no active
 637  *      namespace (i.e., the interpreter is being initialized), the global ::
 638  *      namespace is created and returned.
 639  *
 640  * Results:
 641  *      Returns a pointer to the new namespace if successful. If the namespace
 642  *      already exists or if another error occurs, this routine returns NULL,
 643  *      along with an error message in the interpreter's result object.
 644  *
 645  * Side effects:
 646  *      If the name contains "::" qualifiers and a parent namespace does not
 647  *      already exist, it is automatically created.
 648  *
 649  *----------------------------------------------------------------------
 650  */
 651
 652 Tcl_Namespace *
 653 Tcl_CreateNamespace(
 654     Tcl_Interp *interp,         /* Interpreter in which a new namespace is
 655                                  * being created. Also used for error
 656                                  * reporting. */
 657     const char *name,           /* Name for the new namespace. May be a
 658                                  * qualified name with names of ancestor
 659                                  * namespaces separated by "::"s. */
 660     ClientData clientData,      /* One-word value to store with namespace. */
 661     Tcl_NamespaceDeleteProc *deleteProc)
 662                                 /* Function called to delete client data when
 663                                  * the namespace is deleted. NULL if no
 664                                  * function should be called. */
 665 {
 666     Interp *iPtr = (Interp *) interp;
 667     Namespace *nsPtr, *ancestorPtr;
 668     Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
 669     Namespace *globalNsPtr = iPtr->globalNsPtr;
 670     const char *simpleName;
 671     Tcl_HashEntry *entryPtr;
 672     Tcl_DString buffer1, buffer2;
 673     Tcl_DString *namePtr, *buffPtr;
 674     int newEntry, nameLen;
 675     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 676     const char *nameStr;
 677     Tcl_DString tmpBuffer;
 678
 679     Tcl_DStringInit(&tmpBuffer);
 680
 681     /*
 682      * If there is no active namespace, the interpreter is being initialized.
 683      */
 684
 685     if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
 686         /*
 687          * Treat this namespace as the global namespace, and avoid looking for
 688          * a parent.
 689          */
 690
 691         parentPtr = NULL;
 692         simpleName = "";
 693         goto doCreate;
 694     }
 695
 696     /*
 697      * Ensure that there are no trailing colons as that causes chaos when a
 698      * deleteProc is specified. [Bug d614d63989]
 699      */
 700
 701     if (deleteProc != NULL) {
 702         nameStr = name + strlen(name) - 2;
 703         if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
 704             Tcl_DStringAppend(&tmpBuffer, name, -1);
 705             while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
 706                     && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
 707                 Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
 708             }
 709             name = Tcl_DStringValue(&tmpBuffer);
 710         }
 711     }
 712
 713     /*
 714      * If we've ended up with an empty string now, we're attempting to create
 715      * the global namespace despite the global namespace existing. That's
 716      * naughty!
 717      */
 718
 719     if (*name == '\0') {
 720         Tcl_SetObjResult(interp, Tcl_NewStringObj("can't create namespace"
 721                 " \"\": only global namespace can have empty name", -1));
 722         Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
 723                 "CREATEGLOBAL", NULL);
 724         Tcl_DStringFree(&tmpBuffer);
 725         return NULL;
 726     }
 727
 728     /*
 729      * Find the parent for the new namespace.
 730      */
 731
 732     TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
 733             &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
 734
 735     /*
 736      * If the unqualified name at the end is empty, there were trailing "::"s
 737      * after the namespace's name which we ignore. The new namespace was
 738      * already (recursively) created and is pointed to by parentPtr.
 739      */
 740
 741     if (*simpleName == '\0') {
 742         Tcl_DStringFree(&tmpBuffer);
 743         return (Tcl_Namespace *) parentPtr;
 744     }
 745
 746     /*
 747      * Check for a bad namespace name and make sure that the name does not
 748      * already exist in the parent namespace.
 749      */
 750
 751     if (
 752 #ifndef BREAK_NAMESPACE_COMPAT
 753         Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
 754 #else
 755         parentPtr->childTablePtr != NULL &&
 756         Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
 757 #endif
 758     ) {
 759         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 760                 "can't create namespace \"%s\": already exists", name));
 761         Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
 762                 "CREATEEXISTING", NULL);
 763         Tcl_DStringFree(&tmpBuffer);
 764         return NULL;
 765     }
 766
 767     /*
 768      * Create the new namespace and root it in its parent. Increment the count
 769      * of namespaces created.
 770      */
 771
 772   doCreate:
 773     nsPtr = ckalloc(sizeof(Namespace));
 774     nameLen = strlen(simpleName) + 1;
 775     nsPtr->name = ckalloc(nameLen);
 776     memcpy(nsPtr->name, simpleName, nameLen);
 777     nsPtr->fullName = NULL;             /* Set below. */
 778     nsPtr->clientData = clientData;
 779     nsPtr->deleteProc = deleteProc;
 780     nsPtr->parentPtr = parentPtr;
 781 #ifndef BREAK_NAMESPACE_COMPAT
 782     Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
 783 #else
 784     nsPtr->childTablePtr = NULL;
 785 #endif
 786     nsPtr->nsId = ++(tsdPtr->numNsCreated);
 787     nsPtr->interp = interp;
 788     nsPtr->flags = 0;
 789     nsPtr->activationCount = 0;
 790     nsPtr->refCount = 0;
 791     Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
 792     TclInitVarHashTable(&nsPtr->varTable, nsPtr);
 793     nsPtr->exportArrayPtr = NULL;
 794     nsPtr->numExportPatterns = 0;
 795     nsPtr->maxExportPatterns = 0;
 796     nsPtr->cmdRefEpoch = 0;
 797     nsPtr->resolverEpoch = 0;
 798     nsPtr->cmdResProc = NULL;
 799     nsPtr->varResProc = NULL;
 800     nsPtr->compiledVarResProc = NULL;
 801     nsPtr->exportLookupEpoch = 0;
 802     nsPtr->ensembles = NULL;
 803     nsPtr->unknownHandlerPtr = NULL;
 804     nsPtr->commandPathLength = 0;
 805     nsPtr->commandPathArray = NULL;
 806     nsPtr->commandPathSourceList = NULL;
 807     nsPtr->earlyDeleteProc = NULL;
 808
 809     if (parentPtr != NULL) {
 810         entryPtr = Tcl_CreateHashEntry(
 811                 TclGetNamespaceChildTable((Tcl_Namespace *) parentPtr),
 812                 simpleName, &newEntry);
 813         Tcl_SetHashValue(entryPtr, nsPtr);
 814     } else {
 815         /*
 816          * In the global namespace create traces to maintain the ::errorInfo
 817          * and ::errorCode variables.
 818          */
 819
 820         iPtr->globalNsPtr = nsPtr;
 821         EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
 822         EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
 823     }
 824
 825     /*
 826      * Build the fully qualified name for this namespace.
 827      */
 828
 829     Tcl_DStringInit(&buffer1);
 830     Tcl_DStringInit(&buffer2);
 831     namePtr = &buffer1;
 832     buffPtr = &buffer2;
 833     for (ancestorPtr = nsPtr; ancestorPtr != NULL;
 834             ancestorPtr = ancestorPtr->parentPtr) {
 835         if (ancestorPtr != globalNsPtr) {
 836             Tcl_DString *tempPtr = namePtr;
 837
 838             TclDStringAppendLiteral(buffPtr, "::");
 839             Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
 840             TclDStringAppendDString(buffPtr, namePtr);
 841
 842             /*
 843              * Clear the unwanted buffer or we end up appending to previous
 844              * results, making the namespace fullNames of nested namespaces
 845              * very wrong (and strange).
 846              */
 847
 848             TclDStringClear(namePtr);
 849
 850             /*
 851              * Now swap the buffer pointers so that we build in the other
 852              * buffer. This is faster than repeated copying back and forth
 853              * between buffers.
 854              */
 855
 856             namePtr = buffPtr;
 857             buffPtr = tempPtr;
 858         }
 859     }
 860
 861     name = Tcl_DStringValue(namePtr);
 862     nameLen = Tcl_DStringLength(namePtr);
 863     nsPtr->fullName = ckalloc(nameLen + 1);
 864     memcpy(nsPtr->fullName, name, nameLen + 1);
 865
 866     Tcl_DStringFree(&buffer1);
 867     Tcl_DStringFree(&buffer2);
 868     Tcl_DStringFree(&tmpBuffer);
 869
 870     /*
 871      * If compilation of commands originating from the parent NS is
 872      * suppressed, suppress it for commands originating in this one too.
 873      */
 874
 875     if (nsPtr->parentPtr != NULL &&
 876             nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) {
 877         nsPtr->flags |= NS_SUPPRESS_COMPILATION;
 878     }
 879
 880     /*
 881      * Return a pointer to the new namespace.
 882      */
 883
 884     return (Tcl_Namespace *) nsPtr;
 885 }
 886 \f
 887 /*
 888  *----------------------------------------------------------------------
 889  *
 890  * Tcl_DeleteNamespace --
 891  *
 892  *      Deletes a namespace and all of the commands, variables, and other
 893  *      namespaces within it.
 894  *
 895  * Results:
 896  *      None.
 897  *
 898  * Side effects:
 899  *      When a namespace is deleted, it is automatically removed as a child of
 900  *      its parent namespace. Also, all its commands, variables and child
 901  *      namespaces are deleted.
 902  *
 903  *----------------------------------------------------------------------
 904  */
 905
 906 void
 907 Tcl_DeleteNamespace(
 908     Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
 909 {
 910     Namespace *nsPtr = (Namespace *) namespacePtr;
 911     Interp *iPtr = (Interp *) nsPtr->interp;
 912     Namespace *globalNsPtr = (Namespace *)
 913             TclGetGlobalNamespace((Tcl_Interp *) iPtr);
 914     Tcl_HashEntry *entryPtr;
 915     Tcl_HashSearch search;
 916     Command *cmdPtr;
 917
 918     /*
 919      * Ensure that this namespace doesn't get deallocated in the meantime.
 920      */
 921     nsPtr->refCount++;
 922
 923     /*
 924      * Give anyone interested - notably TclOO - a chance to use this namespace
 925      * normally despite the fact that the namespace is going to go. Allows the
 926      * calling of destructors. Will only be called once (unless re-established
 927      * by the called function). [Bug 2950259]
 928      *
 929      * Note that setting this field requires access to the internal definition
 930      * of namespaces, so it should only be accessed by code that knows about
 931      * being careful with reentrancy.
 932      */
 933
 934     if (nsPtr->earlyDeleteProc != NULL) {
 935         Tcl_NamespaceDeleteProc *earlyDeleteProc = nsPtr->earlyDeleteProc;
 936
 937         nsPtr->earlyDeleteProc = NULL;
 938         nsPtr->activationCount++;
 939         earlyDeleteProc(nsPtr->clientData);
 940         nsPtr->activationCount--;
 941     }
 942
 943     /*
 944      * Delete all coroutine commands now: break the circular ref cycle between
 945      * the namespace and the coroutine command [Bug 2724403]. This code is
 946      * essentially duplicated in TclTeardownNamespace() for all other
 947      * commands. Don't optimize to Tcl_NextHashEntry() because of traces.
 948      *
 949      * NOTE: we could avoid traversing the ns's command list by keeping a
 950      * separate list of coros.
 951      */
 952
 953     for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
 954             entryPtr != NULL;) {
 955         cmdPtr = Tcl_GetHashValue(entryPtr);
 956         if (cmdPtr->nreProc == TclNRInterpCoroutine) {
 957             Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
 958                     (Tcl_Command) cmdPtr);
 959             entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
 960         } else {
 961             entryPtr = Tcl_NextHashEntry(&search);
 962         }
 963     }
 964
 965     /*
 966      * If the namespace has associated ensemble commands, delete them first.
 967      * This leaves the actual contents of the namespace alone (unless they are
 968      * linked ensemble commands, of course). Note that this code is actually
 969      * reentrant so command delete traces won't purturb things badly.
 970      */
 971
 972     while (nsPtr->ensembles != NULL) {
 973         EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;
 974
 975         /*
 976          * Splice out and link to indicate that we've already been killed.
 977          */
 978
 979         nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
 980         ensemblePtr->next = ensemblePtr;
 981         Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
 982     }
 983
 984     /*
 985      * If the namespace has a registered unknown handler (TIP 181), then free
 986      * it here.
 987      */
 988
 989     if (nsPtr->unknownHandlerPtr != NULL) {
 990         Tcl_DecrRefCount(nsPtr->unknownHandlerPtr);
 991         nsPtr->unknownHandlerPtr = NULL;
 992     }
 993
 994     /*
 995      * If the namespace is on the call frame stack, it is marked as "dying"
 996      * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
 997      * name but its commands and variables are still usable by those active
 998      * call frames. When all active call frames referring to the namespace
 999      * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
1000      * function again to delete everything in the namespace. If no nsName
1001      * objects refer to the namespace (i.e., if its refCount is zero), its
1002      * commands and variables are deleted and the storage for its namespace
1003      * structure is freed. Otherwise, if its refCount is nonzero, the
1004      * namespace's commands and variables are deleted but the structure isn't
1005      * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
1006      * namespace resolution code to recognize that the namespace is "deleted".
1007      * The structure's storage is freed by FreeNsNameInternalRep when its
1008      * refCount reaches 0.
1009      */
1010
1011     if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
1012         nsPtr->flags |= NS_DYING;
1013         if (nsPtr->parentPtr != NULL) {
1014             entryPtr = Tcl_FindHashEntry(
1015                     TclGetNamespaceChildTable((Tcl_Namespace *)
1016                             nsPtr->parentPtr), nsPtr->name);
1017             if (entryPtr != NULL) {
1018                 Tcl_DeleteHashEntry(entryPtr);
1019             }
1020         }
1021         nsPtr->parentPtr = NULL;
1022     } else if (!(nsPtr->flags & NS_KILLED)) {
1023         /*
1024          * Delete the namespace and everything in it. If this is the global
1025          * namespace, then clear it but don't free its storage unless the
1026          * interpreter is being torn down. Set the NS_KILLED flag to avoid
1027          * recursive calls here - if the namespace is really in the process of
1028          * being deleted, ignore any second call.
1029          */
1030
1031         nsPtr->flags |= (NS_DYING|NS_KILLED);
1032
1033         TclTeardownNamespace(nsPtr);
1034
1035         if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
1036             /*
1037              * If this is the global namespace, then it may have residual
1038              * "errorInfo" and "errorCode" variables for errors that occurred
1039              * while it was being torn down. Try to clear the variable list
1040              * one last time.
1041              */
1042
1043             TclDeleteNamespaceVars(nsPtr);
1044
1045 #ifndef BREAK_NAMESPACE_COMPAT
1046             Tcl_DeleteHashTable(&nsPtr->childTable);
1047 #else
1048             if (nsPtr->childTablePtr != NULL) {
1049                 Tcl_DeleteHashTable(nsPtr->childTablePtr);
1050                 ckfree(nsPtr->childTablePtr);
1051             }
1052 #endif
1053             Tcl_DeleteHashTable(&nsPtr->cmdTable);
1054
1055             nsPtr ->flags |= NS_DEAD;
1056         } else {
1057             /*
1058              * Restore the ::errorInfo and ::errorCode traces.
1059              */
1060
1061             EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
1062             EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
1063
1064             /*
1065              * We didn't really kill it, so remove the KILLED marks, so it can
1066              * get killed later, avoiding mem leaks.
1067              */
1068
1069             nsPtr->flags &= ~(NS_DYING|NS_KILLED);
1070         }
1071     }
1072     TclNsDecrRefCount(nsPtr);
1073 }
1074
1075 int
1076 TclNamespaceDeleted(
1077     Namespace *nsPtr)
1078 {
1079     return (nsPtr->flags & NS_DYING) ? 1 : 0;
1080 }
1081 \f
1082 /*
1083  *----------------------------------------------------------------------
1084  *
1085  * TclTeardownNamespace --
1086  *
1087  *      Used internally to dismantle and unlink a namespace when it is
1088  *      deleted. Divorces the namespace from its parent, and deletes all
1089  *      commands, variables, and child namespaces.
1090  *
1091  *      This is kept separate from Tcl_DeleteNamespace so that the global
1092  *      namespace can be handled specially.
1093  *
1094  * Results:
1095  *      None.
1096  *
1097  * Side effects:
1098  *      Removes this namespace from its parent's child namespace hashtable.
1099  *      Deletes all commands, variables and namespaces in this namespace.
1100  *
1101  *----------------------------------------------------------------------
1102  */
1103
1104 void
1105 TclTeardownNamespace(
1106     Namespace *nsPtr)   /* Points to the namespace to be dismantled
1107                                  * and unlinked from its parent. */
1108 {
1109     Interp *iPtr = (Interp *) nsPtr->interp;
1110     Tcl_HashEntry *entryPtr;
1111     Tcl_HashSearch search;
1112     int i;
1113
1114     /*
1115      * Start by destroying the namespace's variable table, since variables
1116      * might trigger traces. Variable table should be cleared but not freed!
1117      * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
1118      */
1119
1120     TclDeleteNamespaceVars(nsPtr);
1121     TclInitVarHashTable(&nsPtr->varTable, nsPtr);
1122
1123     /*
1124      * Delete all commands in this namespace. Be careful when traversing the
1125      * hash table: when each command is deleted, it removes itself from the
1126      * command table. Because of traces (and the desire to avoid the quadratic
1127      * problems of just using Tcl_FirstHashEntry over and over, [Bug
1128      * f97d4ee020]) we copy to a temporary array and then delete all those
1129      * commands.
1130      */
1131
1132     while (nsPtr->cmdTable.numEntries > 0) {
1133         int length = nsPtr->cmdTable.numEntries;
1134         Command **cmds = TclStackAlloc((Tcl_Interp *) iPtr,
1135                 sizeof(Command *) * length);
1136
1137         i = 0;
1138         for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1139                 entryPtr != NULL;
1140                 entryPtr = Tcl_NextHashEntry(&search)) {
1141             cmds[i] = Tcl_GetHashValue(entryPtr);
1142             cmds[i]->refCount++;
1143             i++;
1144         }
1145         for (i = 0 ; i < length ; i++) {
1146             Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
1147                     (Tcl_Command) cmds[i]);
1148             TclCleanupCommandMacro(cmds[i]);
1149         }
1150         TclStackFree((Tcl_Interp *) iPtr, cmds);
1151     }
1152     Tcl_DeleteHashTable(&nsPtr->cmdTable);
1153     Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
1154
1155     /*
1156      * Remove the namespace from its parent's child hashtable.
1157      */
1158
1159     if (nsPtr->parentPtr != NULL) {
1160         entryPtr = Tcl_FindHashEntry(
1161                 TclGetNamespaceChildTable((Tcl_Namespace *)
1162                         nsPtr->parentPtr), nsPtr->name);
1163         if (entryPtr != NULL) {
1164             Tcl_DeleteHashEntry(entryPtr);
1165         }
1166     }
1167     nsPtr->parentPtr = NULL;
1168
1169     /*
1170      * Delete the namespace path if one is installed.
1171      */
1172
1173     if (nsPtr->commandPathLength != 0) {
1174         UnlinkNsPath(nsPtr);
1175         nsPtr->commandPathLength = 0;
1176     }
1177     if (nsPtr->commandPathSourceList != NULL) {
1178         NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
1179
1180         do {
1181             if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) {
1182                 nsPathPtr->creatorNsPtr->cmdRefEpoch++;
1183             }
1184             nsPathPtr->nsPtr = NULL;
1185             nsPathPtr = nsPathPtr->nextPtr;
1186         } while (nsPathPtr != NULL);
1187         nsPtr->commandPathSourceList = NULL;
1188     }
1189
1190     /*
1191      * Delete all the child namespaces.
1192      *
1193      * BE CAREFUL: When each child is deleted, it will divorce itself from its
1194      * parent. You can't traverse a hash table properly if its elements are
1195      * being deleted.  Because of traces (and the desire to avoid the
1196      * quadratic problems of just using Tcl_FirstHashEntry over and over, [Bug
1197      * f97d4ee020]) we copy to a temporary array and then delete all those
1198      * namespaces.
1199      *
1200      * Important: leave the hash table itself still live.
1201      */
1202
1203 #ifndef BREAK_NAMESPACE_COMPAT
1204     while (nsPtr->childTable.numEntries > 0) {
1205         int length = nsPtr->childTable.numEntries;
1206         Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
1207                 sizeof(Namespace *) * length);
1208
1209         i = 0;
1210         for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
1211                 entryPtr != NULL;
1212                 entryPtr = Tcl_NextHashEntry(&search)) {
1213             children[i] = Tcl_GetHashValue(entryPtr);
1214             children[i]->refCount++;
1215             i++;
1216         }
1217         for (i = 0 ; i < length ; i++) {
1218             Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
1219             TclNsDecrRefCount(children[i]);
1220         }
1221         TclStackFree((Tcl_Interp *) iPtr, children);
1222     }
1223 #else
1224     if (nsPtr->childTablePtr != NULL) {
1225         while (nsPtr->childTablePtr->numEntries > 0) {
1226             int length = nsPtr->childTablePtr->numEntries;
1227             Namespace **children = TclStackAlloc((Tcl_Interp *) iPtr,
1228                     sizeof(Namespace *) * length);
1229
1230             i = 0;
1231             for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
1232                     entryPtr != NULL;
1233                     entryPtr = Tcl_NextHashEntry(&search)) {
1234                 children[i] = Tcl_GetHashValue(entryPtr);
1235                 children[i]->refCount++;
1236                 i++;
1237             }
1238             for (i = 0 ; i < length ; i++) {
1239                 Tcl_DeleteNamespace((Tcl_Namespace *) children[i]);
1240                 TclNsDecrRefCount(children[i]);
1241             }
1242             TclStackFree((Tcl_Interp *) iPtr, children);
1243         }
1244     }
1245 #endif
1246
1247     /*
1248      * Free the namespace's export pattern array.
1249      */
1250
1251     if (nsPtr->exportArrayPtr != NULL) {
1252         for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
1253             ckfree(nsPtr->exportArrayPtr[i]);
1254         }
1255         ckfree(nsPtr->exportArrayPtr);
1256         nsPtr->exportArrayPtr = NULL;
1257         nsPtr->numExportPatterns = 0;
1258         nsPtr->maxExportPatterns = 0;
1259     }
1260
1261     /*
1262      * Free any client data associated with the namespace.
1263      */
1264
1265     if (nsPtr->deleteProc != NULL) {
1266         nsPtr->deleteProc(nsPtr->clientData);
1267     }
1268     nsPtr->deleteProc = NULL;
1269     nsPtr->clientData = NULL;
1270
1271     /*
1272      * Reset the namespace's id field to ensure that this namespace won't be
1273      * interpreted as valid by, e.g., the cache validation code for cached
1274      * command references in Tcl_GetCommandFromObj.
1275      */
1276
1277     nsPtr->nsId = 0;
1278 }
1279 \f
1280 /*
1281  *----------------------------------------------------------------------
1282  *
1283  * NamespaceFree --
1284  *
1285  *      Called after a namespace has been deleted, when its reference count
1286  *      reaches 0. Frees the data structure representing the namespace.
1287  *
1288  * Results:
1289  *      None.
1290  *
1291  * Side effects:
1292  *      None.
1293  *
1294  *----------------------------------------------------------------------
1295  */
1296
1297 static void
1298 NamespaceFree(
1299     Namespace *nsPtr)   /* Points to the namespace to free. */
1300 {
1301     /*
1302      * Most of the namespace's contents are freed when the namespace is
1303      * deleted by Tcl_DeleteNamespace. All that remains is to free its names
1304      * (for error messages), and the structure itself.
1305      */
1306
1307     ckfree(nsPtr->name);
1308     ckfree(nsPtr->fullName);
1309     ckfree(nsPtr);
1310 }
1311 \f
1312 /*
1313  *----------------------------------------------------------------------
1314  *
1315  * TclNsDecrRefCount --
1316  *
1317  *      Drops a reference to a namespace and frees it if the namespace has
1318  *      been deleted and the last reference has just been dropped.
1319  *
1320  * Results:
1321  *      None.
1322  *
1323  * Side effects:
1324  *      None.
1325  *
1326  *----------------------------------------------------------------------
1327  */
1328
1329 void
1330 TclNsDecrRefCount(
1331     Namespace *nsPtr)
1332 {
1333     nsPtr->refCount--;
1334     if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
1335         NamespaceFree(nsPtr);
1336     }
1337 }
1338 \f
1339 /*
1340  *----------------------------------------------------------------------
1341  *
1342  * Tcl_Export --
1343  *
1344  *      Makes all the commands matching a pattern available to later be
1345  *      imported from the namespace specified by namespacePtr (or the current
1346  *      namespace if namespacePtr is NULL). The specified pattern is appended
1347  *      onto the namespace's export pattern list, which is optionally cleared
1348  *      beforehand.
1349  *
1350  * Results:
1351  *      Returns TCL_OK if successful, or TCL_ERROR (along with an error
1352  *      message in the interpreter's result) if something goes wrong.
1353  *
1354  * Side effects:
1355  *      Appends the export pattern onto the namespace's export list.
1356  *      Optionally reset the namespace's export pattern list.
1357  *
1358  *----------------------------------------------------------------------
1359  */
1360
1361 int
1362 Tcl_Export(
1363     Tcl_Interp *interp,         /* Current interpreter. */
1364     Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands
1365                                  * are to be exported. NULL for the current
1366                                  * namespace. */
1367     const char *pattern,        /* String pattern indicating which commands to
1368                                  * export. This pattern may not include any
1369                                  * namespace qualifiers; only commands in the
1370                                  * specified namespace may be exported. */
1371     int resetListFirst)         /* If nonzero, resets the namespace's export
1372                                  * list before appending. */
1373 {
1374 #define INIT_EXPORT_PATTERNS 5
1375     Namespace *nsPtr, *exportNsPtr, *dummyPtr;
1376     Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1377     const char *simplePattern;
1378     char *patternCpy;
1379     int neededElems, len, i;
1380
1381     /*
1382      * If the specified namespace is NULL, use the current namespace.
1383      */
1384
1385     if (namespacePtr == NULL) {
1386         nsPtr = (Namespace *) currNsPtr;
1387     } else {
1388         nsPtr = (Namespace *) namespacePtr;
1389     }
1390
1391     /*
1392      * If resetListFirst is true (nonzero), clear the namespace's export
1393      * pattern list.
1394      */
1395
1396     if (resetListFirst) {
1397         if (nsPtr->exportArrayPtr != NULL) {
1398             for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
1399                 ckfree(nsPtr->exportArrayPtr[i]);
1400             }
1401             ckfree(nsPtr->exportArrayPtr);
1402             nsPtr->exportArrayPtr = NULL;
1403             TclInvalidateNsCmdLookup(nsPtr);
1404             nsPtr->numExportPatterns = 0;
1405             nsPtr->maxExportPatterns = 0;
1406         }
1407     }
1408
1409     /*
1410      * Check that the pattern doesn't have namespace qualifiers.
1411      */
1412
1413     TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1414             &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1415
1416     if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
1417         Tcl_SetObjResult(interp, Tcl_ObjPrintf("invalid export pattern"
1418                 " \"%s\": pattern can't specify a namespace", pattern));
1419         Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
1420         return TCL_ERROR;
1421     }
1422
1423     /*
1424      * Make sure that we don't already have the pattern in the array
1425      */
1426
1427     if (nsPtr->exportArrayPtr != NULL) {
1428         for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
1429             if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
1430                 /*
1431                  * The pattern already exists in the list.
1432                  */
1433
1434                 return TCL_OK;
1435             }
1436         }
1437     }
1438
1439     /*
1440      * Make sure there is room in the namespace's pattern array for the new
1441      * pattern.
1442      */
1443
1444     neededElems = nsPtr->numExportPatterns + 1;
1445     if (neededElems > nsPtr->maxExportPatterns) {
1446         nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
1447                 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
1448         nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr,
1449                 sizeof(char *) * nsPtr->maxExportPatterns);
1450     }
1451
1452     /*
1453      * Add the pattern to the namespace's array of export patterns.
1454      */
1455
1456     len = strlen(pattern);
1457     patternCpy = ckalloc(len + 1);
1458     memcpy(patternCpy, pattern, len + 1);
1459
1460     nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
1461     nsPtr->numExportPatterns++;
1462
1463     /*
1464      * The list of commands actually exported from the namespace might have
1465      * changed (probably will have!) However, we do not need to recompute this
1466      * just yet; next time we need the info will be soon enough.
1467      */
1468
1469     TclInvalidateNsCmdLookup(nsPtr);
1470
1471     return TCL_OK;
1472 #undef INIT_EXPORT_PATTERNS
1473 }
1474 \f
1475 /*
1476  *----------------------------------------------------------------------
1477  *
1478  * Tcl_AppendExportList --
1479  *
1480  *      Appends onto the argument object the list of export patterns for the
1481  *      specified namespace.
1482  *
1483  * Results:
1484  *      The return value is normally TCL_OK; in this case the object
1485  *      referenced by objPtr has each export pattern appended to it. If an
1486  *      error occurs, TCL_ERROR is returned and the interpreter's result holds
1487  *      an error message.
1488  *
1489  * Side effects:
1490  *      If necessary, the object referenced by objPtr is converted into a list
1491  *      object.
1492  *
1493  *----------------------------------------------------------------------
1494  */
1495
1496 int
1497 Tcl_AppendExportList(
1498     Tcl_Interp *interp,         /* Interpreter used for error reporting. */
1499     Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
1500                                  * pattern list is appended onto objPtr. NULL
1501                                  * for the current namespace. */
1502     Tcl_Obj *objPtr)            /* Points to the Tcl object onto which the
1503                                  * export pattern list is appended. */
1504 {
1505     Namespace *nsPtr;
1506     int i, result;
1507
1508     /*
1509      * If the specified namespace is NULL, use the current namespace.
1510      */
1511
1512     if (namespacePtr == NULL) {
1513         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1514     } else {
1515         nsPtr = (Namespace *) namespacePtr;
1516     }
1517
1518     /*
1519      * Append the export pattern list onto objPtr.
1520      */
1521
1522     for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
1523         result = Tcl_ListObjAppendElement(interp, objPtr,
1524                 Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
1525         if (result != TCL_OK) {
1526             return result;
1527         }
1528     }
1529     return TCL_OK;
1530 }
1531 \f
1532 /*
1533  *----------------------------------------------------------------------
1534  *
1535  * Tcl_Import --
1536  *
1537  *      Imports all of the commands matching a pattern into the namespace
1538  *      specified by namespacePtr (or the current namespace if contextNsPtr is
1539  *      NULL). This is done by creating a new command (the "imported command")
1540  *      that points to the real command in its original namespace.
1541  *
1542  *      If matching commands are on the autoload path but haven't been loaded
1543  *      yet, this command forces them to be loaded, then creates the links to
1544  *      them.
1545  *
1546  * Results:
1547  *      Returns TCL_OK if successful, or TCL_ERROR (along with an error
1548  *      message in the interpreter's result) if something goes wrong.
1549  *
1550  * Side effects:
1551  *      Creates new commands in the importing namespace. These indirect calls
1552  *      back to the real command and are deleted if the real commands are
1553  *      deleted.
1554  *
1555  *----------------------------------------------------------------------
1556  */
1557
1558 int
1559 Tcl_Import(
1560     Tcl_Interp *interp,         /* Current interpreter. */
1561     Tcl_Namespace *namespacePtr,/* Points to the namespace into which the
1562                                  * commands are to be imported. NULL for the
1563                                  * current namespace. */
1564     const char *pattern,        /* String pattern indicating which commands to
1565                                  * import. This pattern should be qualified by
1566                                  * the name of the namespace from which to
1567                                  * import the command(s). */
1568     int allowOverwrite)         /* If nonzero, allow existing commands to be
1569                                  * overwritten by imported commands. If 0,
1570                                  * return an error if an imported cmd
1571                                  * conflicts with an existing one. */
1572 {
1573     Namespace *nsPtr, *importNsPtr, *dummyPtr;
1574     const char *simplePattern;
1575     Tcl_HashEntry *hPtr;
1576     Tcl_HashSearch search;
1577
1578     /*
1579      * If the specified namespace is NULL, use the current namespace.
1580      */
1581
1582     if (namespacePtr == NULL) {
1583         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1584     } else {
1585         nsPtr = (Namespace *) namespacePtr;
1586     }
1587
1588     /*
1589      * First, invoke the "auto_import" command with the pattern being
1590      * imported. This command is part of the Tcl library. It looks for
1591      * imported commands in autoloaded libraries and loads them in. That way,
1592      * they will be found when we try to create links below.
1593      *
1594      * Note that we don't just call Tcl_EvalObjv() directly because we do not
1595      * want absence of the command to be a failure case.
1596      */
1597
1598     if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
1599         Tcl_Obj *objv[2];
1600         int result;
1601
1602         TclNewLiteralStringObj(objv[0], "auto_import");
1603         objv[1] = Tcl_NewStringObj(pattern, -1);
1604
1605         Tcl_IncrRefCount(objv[0]);
1606         Tcl_IncrRefCount(objv[1]);
1607         result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
1608         Tcl_DecrRefCount(objv[0]);
1609         Tcl_DecrRefCount(objv[1]);
1610
1611         if (result != TCL_OK) {
1612             return TCL_ERROR;
1613         }
1614         Tcl_ResetResult(interp);
1615     }
1616
1617     /*
1618      * From the pattern, find the namespace from which we are importing and
1619      * get the simple pattern (no namespace qualifiers or ::'s) at the end.
1620      */
1621
1622     if (strlen(pattern) == 0) {
1623         Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
1624         Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
1625         return TCL_ERROR;
1626     }
1627     TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1628             &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1629
1630     if (importNsPtr == NULL) {
1631         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1632                 "unknown namespace in import pattern \"%s\"", pattern));
1633         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
1634         return TCL_ERROR;
1635     }
1636     if (importNsPtr == nsPtr) {
1637         if (pattern == simplePattern) {
1638             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1639                     "no namespace specified in import pattern \"%s\"",
1640                     pattern));
1641             Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
1642         } else {
1643             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1644                     "import pattern \"%s\" tries to import from namespace"
1645                     " \"%s\" into itself", pattern, importNsPtr->name));
1646             Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
1647         }
1648         return TCL_ERROR;
1649     }
1650
1651     /*
1652      * Scan through the command table in the source namespace and look for
1653      * exported commands that match the string pattern. Create an "imported
1654      * command" in the current namespace for each imported command; these
1655      * commands redirect their invocations to the "real" command.
1656      */
1657
1658     if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) {
1659         hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern);
1660         if (hPtr == NULL) {
1661             return TCL_OK;
1662         }
1663         return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
1664                 importNsPtr, allowOverwrite);
1665     }
1666     for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
1667             (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
1668         char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
1669
1670         if (Tcl_StringMatch(cmdName, simplePattern) &&
1671                 DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
1672                 allowOverwrite) == TCL_ERROR) {
1673             return TCL_ERROR;
1674         }
1675     }
1676     return TCL_OK;
1677 }
1678 \f
1679 /*
1680  *----------------------------------------------------------------------
1681  *
1682  * DoImport --
1683  *
1684  *      Import a particular command from one namespace into another. Helper
1685  *      for Tcl_Import().
1686  *
1687  * Results:
1688  *      Standard Tcl result code. If TCL_ERROR, appends an error message to
1689  *      the interpreter result.
1690  *
1691  * Side effects:
1692  *      A new command is created in the target namespace unless this is a
1693  *      reimport of exactly the same command as before.
1694  *
1695  *----------------------------------------------------------------------
1696  */
1697
1698 static int
1699 DoImport(
1700     Tcl_Interp *interp,
1701     Namespace *nsPtr,
1702     Tcl_HashEntry *hPtr,
1703     const char *cmdName,
1704     const char *pattern,
1705     Namespace *importNsPtr,
1706     int allowOverwrite)
1707 {
1708     int i = 0, exported = 0;
1709     Tcl_HashEntry *found;
1710
1711     /*
1712      * The command cmdName in the source namespace matches the pattern. Check
1713      * whether it was exported. If it wasn't, we ignore it.
1714      */
1715
1716     while (!exported && (i < importNsPtr->numExportPatterns)) {
1717         exported |= Tcl_StringMatch(cmdName,
1718                 importNsPtr->exportArrayPtr[i++]);
1719     }
1720     if (!exported) {
1721         return TCL_OK;
1722     }
1723
1724     /*
1725      * Unless there is a name clash, create an imported command in the current
1726      * namespace that refers to cmdPtr.
1727      */
1728
1729     found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
1730     if ((found == NULL) || allowOverwrite) {
1731         /*
1732          * Create the imported command and its client data. To create the new
1733          * command in the current namespace, generate a fully qualified name
1734          * for it.
1735          */
1736
1737         Tcl_DString ds;
1738         Tcl_Command importedCmd;
1739         ImportedCmdData *dataPtr;
1740         Command *cmdPtr;
1741         ImportRef *refPtr;
1742
1743         Tcl_DStringInit(&ds);
1744         Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
1745         if (nsPtr != ((Interp *) interp)->globalNsPtr) {
1746             TclDStringAppendLiteral(&ds, "::");
1747         }
1748         Tcl_DStringAppend(&ds, cmdName, -1);
1749
1750         /*
1751          * Check whether creating the new imported command in the current
1752          * namespace would create a cycle of imported command references.
1753          */
1754
1755         cmdPtr = Tcl_GetHashValue(hPtr);
1756         if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
1757             Command *overwrite = Tcl_GetHashValue(found);
1758             Command *linkCmd = cmdPtr;
1759
1760             while (linkCmd->deleteProc == DeleteImportedCmd) {
1761                 dataPtr = linkCmd->objClientData;
1762                 linkCmd = dataPtr->realCmdPtr;
1763                 if (overwrite == linkCmd) {
1764                     Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1765                             "import pattern \"%s\" would create a loop"
1766                             " containing command \"%s\"",
1767                             pattern, Tcl_DStringValue(&ds)));
1768                     Tcl_DStringFree(&ds);
1769                     Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
1770                     return TCL_ERROR;
1771                 }
1772             }
1773         }
1774
1775         dataPtr = ckalloc(sizeof(ImportedCmdData));
1776         importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
1777                 InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
1778                 DeleteImportedCmd);
1779         dataPtr->realCmdPtr = cmdPtr;
1780         dataPtr->selfPtr = (Command *) importedCmd;
1781         dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
1782         Tcl_DStringFree(&ds);
1783
1784         /*
1785          * Create an ImportRef structure describing this new import command
1786          * and add it to the import ref list in the "real" command.
1787          */
1788
1789         refPtr = ckalloc(sizeof(ImportRef));
1790         refPtr->importedCmdPtr = (Command *) importedCmd;
1791         refPtr->nextPtr = cmdPtr->importRefPtr;
1792         cmdPtr->importRefPtr = refPtr;
1793     } else {
1794         Command *overwrite = Tcl_GetHashValue(found);
1795
1796         if (overwrite->deleteProc == DeleteImportedCmd) {
1797             ImportedCmdData *dataPtr = overwrite->objClientData;
1798
1799             if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
1800                 /*
1801                  * Repeated import of same command is acceptable.
1802                  */
1803
1804                 return TCL_OK;
1805             }
1806         }
1807         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1808                 "can't import command \"%s\": already exists", cmdName));
1809         Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
1810         return TCL_ERROR;
1811     }
1812     return TCL_OK;
1813 }
1814 \f
1815 /*
1816  *----------------------------------------------------------------------
1817  *
1818  * Tcl_ForgetImport --
1819  *
1820  *      Deletes commands previously imported into the namespace indicated.
1821  *      The by namespacePtr, or the current namespace of interp, when
1822  *      namespacePtr is NULL. The pattern controls which imported commands are
1823  *      deleted. A simple pattern, one without namespace separators, matches
1824  *      the current command names of imported commands in the namespace.
1825  *      Matching imported commands are deleted. A qualified pattern is
1826  *      interpreted as deletion selection on the basis of where the command is
1827  *      imported from. The original command and "first link" command for each
1828  *      imported command are determined, and they are matched against the
1829  *      pattern. A match leads to deletion of the imported command.
1830  *
1831  * Results:
1832  *      Returns TCL_ERROR and records an error message in the interp result if
1833  *      a namespace qualified pattern refers to a namespace that does not
1834  *      exist. Otherwise, returns TCL_OK.
1835  *
1836  * Side effects:
1837  *      May delete commands.
1838  *
1839  *----------------------------------------------------------------------
1840  */
1841
1842 int
1843 Tcl_ForgetImport(
1844     Tcl_Interp *interp,         /* Current interpreter. */
1845     Tcl_Namespace *namespacePtr,/* Points to the namespace from which
1846                                  * previously imported commands should be
1847                                  * removed. NULL for current namespace. */
1848     const char *pattern)        /* String pattern indicating which imported
1849                                  * commands to remove. */
1850 {
1851     Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
1852     const char *simplePattern;
1853     char *cmdName;
1854     Tcl_HashEntry *hPtr;
1855     Tcl_HashSearch search;
1856
1857     /*
1858      * If the specified namespace is NULL, use the current namespace.
1859      */
1860
1861     if (namespacePtr == NULL) {
1862         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1863     } else {
1864         nsPtr = (Namespace *) namespacePtr;
1865     }
1866
1867     /*
1868      * Parse the pattern into its namespace-qualification (if any) and the
1869      * simple pattern.
1870      */
1871
1872     TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1873             &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1874
1875     if (sourceNsPtr == NULL) {
1876         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1877                 "unknown namespace in namespace forget pattern \"%s\"",
1878                 pattern));
1879         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
1880         return TCL_ERROR;
1881     }
1882
1883     if (strcmp(pattern, simplePattern) == 0) {
1884         /*
1885          * The pattern is simple. Delete any imported commands that match it.
1886          */
1887
1888         if (TclMatchIsTrivial(simplePattern)) {
1889             hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
1890             if (hPtr != NULL) {
1891                 Command *cmdPtr = Tcl_GetHashValue(hPtr);
1892
1893                 if (cmdPtr && (cmdPtr->deleteProc == DeleteImportedCmd)) {
1894                     Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1895                 }
1896             }
1897             return TCL_OK;
1898         }
1899         for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1900                 (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
1901             Command *cmdPtr = Tcl_GetHashValue(hPtr);
1902
1903             if (cmdPtr->deleteProc != DeleteImportedCmd) {
1904                 continue;
1905             }
1906             cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
1907             if (Tcl_StringMatch(cmdName, simplePattern)) {
1908                 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1909             }
1910         }
1911         return TCL_OK;
1912     }
1913
1914     /*
1915      * The pattern was namespace-qualified.
1916      */
1917
1918     for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
1919             hPtr = Tcl_NextHashEntry(&search)) {
1920         Tcl_CmdInfo info;
1921         Tcl_Command token = Tcl_GetHashValue(hPtr);
1922         Tcl_Command origin = TclGetOriginalCommand(token);
1923
1924         if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
1925             continue;                   /* Not an imported command. */
1926         }
1927         if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1928             /*
1929              * Original not in namespace we're matching. Check the first link
1930              * in the import chain.
1931              */
1932
1933             Command *cmdPtr = (Command *) token;
1934             ImportedCmdData *dataPtr = cmdPtr->objClientData;
1935             Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
1936
1937             if (firstToken == origin) {
1938                 continue;
1939             }
1940             Tcl_GetCommandInfoFromToken(firstToken, &info);
1941             if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1942                 continue;
1943             }
1944             origin = firstToken;
1945         }
1946         if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){
1947             Tcl_DeleteCommandFromToken(interp, token);
1948         }
1949     }
1950     return TCL_OK;
1951 }
1952 \f
1953 /*
1954  *----------------------------------------------------------------------
1955  *
1956  * TclGetOriginalCommand --
1957  *
1958  *      An imported command is created in an namespace when a "real" command
1959  *      is imported from another namespace. If the specified command is an
1960  *      imported command, this function returns the original command it refers
1961  *      to.
1962  *
1963  * Results:
1964  *      If the command was imported into a sequence of namespaces a, b,...,n
1965  *      where each successive namespace just imports the command from the
1966  *      previous namespace, this function returns the Tcl_Command token in the
1967  *      first namespace, a. Otherwise, if the specified command is not an
1968  *      imported command, the function returns NULL.
1969  *
1970  * Side effects:
1971  *      None.
1972  *
1973  *----------------------------------------------------------------------
1974  */
1975
1976 Tcl_Command
1977 TclGetOriginalCommand(
1978     Tcl_Command command)        /* The imported command for which the original
1979                                  * command should be returned. */
1980 {
1981     Command *cmdPtr = (Command *) command;
1982     ImportedCmdData *dataPtr;
1983
1984     if (cmdPtr->deleteProc != DeleteImportedCmd) {
1985         return NULL;
1986     }
1987
1988     while (cmdPtr->deleteProc == DeleteImportedCmd) {
1989         dataPtr = cmdPtr->objClientData;
1990         cmdPtr = dataPtr->realCmdPtr;
1991     }
1992     return (Tcl_Command) cmdPtr;
1993 }
1994 \f
1995 /*
1996  *----------------------------------------------------------------------
1997  *
1998  * InvokeImportedCmd --
1999  *
2000  *      Invoked by Tcl whenever the user calls an imported command that was
2001  *      created by Tcl_Import. Finds the "real" command (in another
2002  *      namespace), and passes control to it.
2003  *
2004  * Results:
2005  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
2006  *
2007  * Side effects:
2008  *      Returns a result in the interpreter's result object. If anything goes
2009  *      wrong, the result object is set to an error message.
2010  *
2011  *----------------------------------------------------------------------
2012  */
2013
2014 static int
2015 InvokeImportedNRCmd(
2016     ClientData clientData,      /* Points to the imported command's
2017                                  * ImportedCmdData structure. */
2018     Tcl_Interp *interp,         /* Current interpreter. */
2019     int objc,                   /* Number of arguments. */
2020     Tcl_Obj *const objv[])      /* The argument objects. */
2021 {
2022     ImportedCmdData *dataPtr = clientData;
2023     Command *realCmdPtr = dataPtr->realCmdPtr;
2024
2025     TclSkipTailcall(interp);
2026     return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr);
2027 }
2028
2029 static int
2030 InvokeImportedCmd(
2031     ClientData clientData,      /* Points to the imported command's
2032                                  * ImportedCmdData structure. */
2033     Tcl_Interp *interp,         /* Current interpreter. */
2034     int objc,                   /* Number of arguments. */
2035     Tcl_Obj *const objv[])      /* The argument objects. */
2036 {
2037     return Tcl_NRCallObjProc(interp, InvokeImportedNRCmd, clientData,
2038             objc, objv);
2039 }
2040 \f
2041 /*
2042  *----------------------------------------------------------------------
2043  *
2044  * DeleteImportedCmd --
2045  *
2046  *      Invoked by Tcl whenever an imported command is deleted. The "real"
2047  *      command keeps a list of all the imported commands that refer to it, so
2048  *      those imported commands can be deleted when the real command is
2049  *      deleted. This function removes the imported command reference from the
2050  *      real command's list, and frees up the memory associated with the
2051  *      imported command.
2052  *
2053  * Results:
2054  *      None.
2055  *
2056  * Side effects:
2057  *      Removes the imported command from the real command's import list.
2058  *
2059  *----------------------------------------------------------------------
2060  */
2061
2062 static void
2063 DeleteImportedCmd(
2064     ClientData clientData)      /* Points to the imported command's
2065                                  * ImportedCmdData structure. */
2066 {
2067     ImportedCmdData *dataPtr = clientData;
2068     Command *realCmdPtr = dataPtr->realCmdPtr;
2069     Command *selfPtr = dataPtr->selfPtr;
2070     ImportRef *refPtr, *prevPtr;
2071
2072     prevPtr = NULL;
2073     for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
2074             refPtr = refPtr->nextPtr) {
2075         if (refPtr->importedCmdPtr == selfPtr) {
2076             /*
2077              * Remove *refPtr from real command's list of imported commands
2078              * that refer to it.
2079              */
2080
2081             if (prevPtr == NULL) { /* refPtr is first in list. */
2082                 realCmdPtr->importRefPtr = refPtr->nextPtr;
2083             } else {
2084                 prevPtr->nextPtr = refPtr->nextPtr;
2085             }
2086             ckfree(refPtr);
2087             ckfree(dataPtr);
2088             return;
2089         }
2090         prevPtr = refPtr;
2091     }
2092
2093     Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
2094 }
2095 \f
2096 /*
2097  *----------------------------------------------------------------------
2098  *
2099  * TclGetNamespaceForQualName --
2100  *
2101  *      Given a qualified name specifying a command, variable, or namespace,
2102  *      and a namespace in which to resolve the name, this function returns a
2103  *      pointer to the namespace that contains the item. A qualified name
2104  *      consists of the "simple" name of an item qualified by the names of an
2105  *      arbitrary number of containing namespace separated by "::"s. If the
2106  *      qualified name starts with "::", it is interpreted absolutely from the
2107  *      global namespace. Otherwise, it is interpreted relative to the
2108  *      namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is
2109  *      NULL, the name is interpreted relative to the current namespace.
2110  *
2111  *      A relative name like "foo::bar::x" can be found starting in either the
2112  *      current namespace or in the global namespace. So each search usually
2113  *      follows two tracks, and two possible namespaces are returned. If the
2114  *      function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path
2115  *      failed.
2116  *
2117  *      If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
2118  *      sought only in the global :: namespace. The alternate search (also)
2119  *      starting from the global namespace is ignored and *altNsPtrPtr is set
2120  *      NULL.
2121  *
2122  *      If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is
2123  *      sought only in the namespace specified by cxtNsPtr. The alternate
2124  *      search starting from the global namespace is ignored and *altNsPtrPtr
2125  *      is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are
2126  *      specified, TCL_GLOBAL_ONLY is ignored and the search starts from the
2127  *      namespace specified by cxtNsPtr.
2128  *
2129  *      If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components
2130  *      of the qualified name that cannot be found are automatically created
2131  *      within their specified parent. This makes sure that functions like
2132  *      Tcl_CreateCommand always succeed. There is no alternate search path,
2133  *      so *altNsPtrPtr is set NULL.
2134  *
2135  *      If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as
2136  *      a reference to a namespace, and the entire qualified name is followed.
2137  *      If the name is relative, the namespace is looked up only in the
2138  *      current namespace. A pointer to the namespace is stored in *nsPtrPtr
2139  *      and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS
2140  *      is not specified, only the leading components are treated as namespace
2141  *      names, and a pointer to the simple name of the final component is
2142  *      stored in *simpleNamePtr.
2143  *
2144  * Results:
2145  *      It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
2146  *      namespaces which represent the last (containing) namespace in the
2147  *      qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr
2148  *      to NULL, then the search along that path failed. The function also
2149  *      stores a pointer to the simple name of the final component in
2150  *      *simpleNamePtr. If the qualified name is "::" or was treated as a
2151  *      namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer
2152  *      to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
2153  *      *simpleNamePtr to point to an empty string.
2154  *
2155  *      If there is an error, this function returns TCL_ERROR. If "flags"
2156  *      contains TCL_LEAVE_ERR_MSG, an error message is returned in the
2157  *      interpreter's result object. Otherwise, the interpreter's result
2158  *      object is left unchanged.
2159  *
2160  *      *actualCxtPtrPtr is set to the actual context namespace. It is set to
2161  *      the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL,
2162  *      it is set to the current namespace context.
2163  *
2164  *      For backwards compatibility with the TclPro byte code loader, this
2165  *      function always returns TCL_OK.
2166  *
2167  * Side effects:
2168  *      If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
2169  *      created.
2170  *
2171  *----------------------------------------------------------------------
2172  */
2173
2174 int
2175 TclGetNamespaceForQualName(
2176     Tcl_Interp *interp,         /* Interpreter in which to find the namespace
2177                                  * containing qualName. */
2178     const char *qualName,       /* A namespace-qualified name of an command,
2179                                  * variable, or namespace. */
2180     Namespace *cxtNsPtr,        /* The namespace in which to start the search
2181                                  * for qualName's namespace. If NULL start
2182                                  * from the current namespace. Ignored if
2183                                  * TCL_GLOBAL_ONLY is set. */
2184     int flags,                  /* Flags controlling the search: an OR'd
2185                                  * combination of TCL_GLOBAL_ONLY,
2186                                  * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and
2187                                  * TCL_CREATE_NS_IF_UNKNOWN. */
2188     Namespace **nsPtrPtr,       /* Address where function stores a pointer to
2189                                  * containing namespace if qualName is found
2190                                  * starting from *cxtNsPtr or, if
2191                                  * TCL_GLOBAL_ONLY is set, if qualName is
2192                                  * found in the global :: namespace. NULL is
2193                                  * stored otherwise. */
2194     Namespace **altNsPtrPtr,    /* Address where function stores a pointer to
2195                                  * containing namespace if qualName is found
2196                                  * starting from the global :: namespace.
2197                                  * NULL is stored if qualName isn't found
2198                                  * starting from :: or if the TCL_GLOBAL_ONLY,
2199                                  * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS,
2200                                  * TCL_CREATE_NS_IF_UNKNOWN flag is set. */
2201     Namespace **actualCxtPtrPtr,/* Address where function stores a pointer to
2202                                  * the actual namespace from which the search
2203                                  * started. This is either cxtNsPtr, the ::
2204                                  * namespace if TCL_GLOBAL_ONLY was specified,
2205                                  * or the current namespace if cxtNsPtr was
2206                                  * NULL. */
2207     const char **simpleNamePtr) /* Address where function stores the simple
2208                                  * name at end of the qualName, or NULL if
2209                                  * qualName is "::" or the flag
2210                                  * TCL_FIND_ONLY_NS was specified. */
2211 {
2212     Interp *iPtr = (Interp *) interp;
2213     Namespace *nsPtr = cxtNsPtr;
2214     Namespace *altNsPtr;
2215     Namespace *globalNsPtr = iPtr->globalNsPtr;
2216     const char *start, *end;
2217     const char *nsName;
2218     Tcl_HashEntry *entryPtr;
2219     Tcl_DString buffer;
2220     int len;
2221
2222     /*
2223      * Determine the context namespace nsPtr in which to start the primary
2224      * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was
2225      * specified, search from the global namespace. Otherwise, use the
2226      * namespace given in cxtNsPtr, or if that is NULL, use the current
2227      * namespace context. Note that we always treat two or more adjacent ":"s
2228      * as a namespace separator.
2229      */
2230
2231     if (flags & TCL_GLOBAL_ONLY) {
2232         nsPtr = globalNsPtr;
2233     } else if (nsPtr == NULL) {
2234         nsPtr = iPtr->varFramePtr->nsPtr;
2235     }
2236
2237     start = qualName;                   /* Points to start of qualifying
2238                                          * namespace. */
2239     if ((*qualName == ':') && (*(qualName+1) == ':')) {
2240         start = qualName+2;             /* Skip over the initial :: */
2241         while (*start == ':') {
2242             start++;                    /* Skip over a subsequent : */
2243         }
2244         nsPtr = globalNsPtr;
2245         if (*start == '\0') {           /* qualName is just two or more
2246                                          * ":"s. */
2247             *nsPtrPtr = globalNsPtr;
2248             *altNsPtrPtr = NULL;
2249             *actualCxtPtrPtr = globalNsPtr;
2250             *simpleNamePtr = start;     /* Points to empty string. */
2251             return TCL_OK;
2252         }
2253     }
2254     *actualCxtPtrPtr = nsPtr;
2255
2256     /*
2257      * Start an alternate search path starting with the global namespace.
2258      * However, if the starting context is the global namespace, or if the
2259      * flag is set to search only the namespace *cxtNsPtr, ignore the
2260      * alternate search path.
2261      */
2262
2263     altNsPtr = globalNsPtr;
2264     if ((nsPtr == globalNsPtr)
2265             || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) {
2266         altNsPtr = NULL;
2267     }
2268
2269     /*
2270      * Loop to resolve each namespace qualifier in qualName.
2271      */
2272
2273     Tcl_DStringInit(&buffer);
2274     end = start;
2275     while (*start != '\0') {
2276         /*
2277          * Find the next namespace qualifier (i.e., a name ending in "::") or
2278          * the end of the qualified name (i.e., a name ending in "\0"). Set
2279          * len to the number of characters, starting from start, in the name;
2280          * set end to point after the "::"s or at the "\0".
2281          */
2282
2283         len = 0;
2284         for (end = start;  *end != '\0';  end++) {
2285             if ((*end == ':') && (*(end+1) == ':')) {
2286                 end += 2;               /* Skip over the initial :: */
2287                 while (*end == ':') {
2288                     end++;              /* Skip over the subsequent : */
2289                 }
2290                 break;                  /* Exit for loop; end is after ::'s */
2291             }
2292             len++;
2293         }
2294
2295         if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
2296             /*
2297              * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
2298              * was specified, look this up as a namespace. Otherwise, start is
2299              * the name of a cmd or var and we are done.
2300              */
2301
2302             if (flags & TCL_FIND_ONLY_NS) {
2303                 nsName = start;
2304             } else {
2305                 *nsPtrPtr = nsPtr;
2306                 *altNsPtrPtr = altNsPtr;
2307                 *simpleNamePtr = start;
2308                 Tcl_DStringFree(&buffer);
2309                 return TCL_OK;
2310             }
2311         } else {
2312             /*
2313              * start points to the beginning of a namespace qualifier ending
2314              * in "::". end points to the start of a name in that namespace
2315              * that might be empty. Copy the namespace qualifier to a buffer
2316              * so it can be null terminated. We can't modify the incoming
2317              * qualName since it may be a string constant.
2318              */
2319
2320             TclDStringClear(&buffer);
2321             Tcl_DStringAppend(&buffer, start, len);
2322             nsName = Tcl_DStringValue(&buffer);
2323         }
2324
2325         /*
2326          * Look up the namespace qualifier nsName in the current namespace
2327          * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
2328          * create that qualifying namespace. This is needed for functions like
2329          * Tcl_CreateCommand that cannot fail.
2330          */
2331
2332         if (nsPtr != NULL) {
2333 #ifndef BREAK_NAMESPACE_COMPAT
2334             entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
2335 #else
2336             if (nsPtr->childTablePtr == NULL) {
2337                 entryPtr = NULL;
2338             } else {
2339                 entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
2340             }
2341 #endif
2342             if (entryPtr != NULL) {
2343                 nsPtr = Tcl_GetHashValue(entryPtr);
2344             } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
2345                 Tcl_CallFrame *framePtr;
2346
2347                 (void) TclPushStackFrame(interp, &framePtr,
2348                         (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
2349
2350                 nsPtr = (Namespace *)
2351                         Tcl_CreateNamespace(interp, nsName, NULL, NULL);
2352                 TclPopStackFrame(interp);
2353
2354                 if (nsPtr == NULL) {
2355                     Tcl_Panic("Could not create namespace '%s'", nsName);
2356                 }
2357             } else {                    /* Namespace not found and was not
2358                                          * created. */
2359                 nsPtr = NULL;
2360             }
2361         }
2362
2363         /*
2364          * Look up the namespace qualifier in the alternate search path too.
2365          */
2366
2367         if (altNsPtr != NULL) {
2368 #ifndef BREAK_NAMESPACE_COMPAT
2369             entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
2370 #else
2371             if (altNsPtr->childTablePtr != NULL) {
2372                 entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
2373             } else {
2374                 entryPtr = NULL;
2375             }
2376 #endif
2377             if (entryPtr != NULL) {
2378                 altNsPtr = Tcl_GetHashValue(entryPtr);
2379             } else {
2380                 altNsPtr = NULL;
2381             }
2382         }
2383
2384         /*
2385          * If both search paths have failed, return NULL results.
2386          */
2387
2388         if ((nsPtr == NULL) && (altNsPtr == NULL)) {
2389             *nsPtrPtr = NULL;
2390             *altNsPtrPtr = NULL;
2391             *simpleNamePtr = NULL;
2392             Tcl_DStringFree(&buffer);
2393             return TCL_OK;
2394         }
2395
2396         start = end;
2397     }
2398
2399     /*
2400      * We ignore trailing "::"s in a namespace name, but in a command or
2401      * variable name, trailing "::"s refer to the cmd or var named {}.
2402      */
2403
2404     if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
2405         *simpleNamePtr = NULL;          /* Found namespace name. */
2406     } else {
2407         *simpleNamePtr = end;           /* Found cmd/var: points to empty
2408                                          * string. */
2409     }
2410
2411     /*
2412      * As a special case, if we are looking for a namespace and qualName is ""
2413      * and the current active namespace (nsPtr) is not the global namespace,
2414      * return NULL (no namespace was found). This is because namespaces can
2415      * not have empty names except for the global namespace.
2416      */
2417
2418     if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
2419             && (nsPtr != globalNsPtr)) {
2420         nsPtr = NULL;
2421     }
2422
2423     *nsPtrPtr = nsPtr;
2424     *altNsPtrPtr = altNsPtr;
2425     Tcl_DStringFree(&buffer);
2426     return TCL_OK;
2427 }
2428 \f
2429 /*
2430  *----------------------------------------------------------------------
2431  *
2432  * TclEnsureNamespace --
2433  *
2434  *      Provide a namespace that is not deleted.
2435  *
2436  * Value
2437  *
2438  *      namespacePtr, if it is not scheduled for deletion, or a pointer to a
2439  *      new namespace with the same name otherwise.
2440  *
2441  * Effect
2442  *      None.
2443  *
2444  *----------------------------------------------------------------------
2445  */
2446 Tcl_Namespace *
2447 TclEnsureNamespace(
2448     Tcl_Interp *interp,
2449     Tcl_Namespace *namespacePtr)
2450 {
2451     Namespace *nsPtr = (Namespace *) namespacePtr;
2452     if (!(nsPtr->flags & NS_DYING)) {
2453             return namespacePtr;
2454     }
2455     return Tcl_CreateNamespace(interp, nsPtr->fullName, NULL, NULL);
2456 }
2457 \f
2458 /*
2459  *----------------------------------------------------------------------
2460  *
2461  * Tcl_FindNamespace --
2462  *
2463  *      Searches for a namespace.
2464  *
2465  * Results:
2466  *      Returns a pointer to the namespace if it is found. Otherwise, returns
2467  *      NULL and leaves an error message in the interpreter's result object if
2468  *      "flags" contains TCL_LEAVE_ERR_MSG.
2469  *
2470  * Side effects:
2471  *      None.
2472  *
2473  *----------------------------------------------------------------------
2474  */
2475
2476 Tcl_Namespace *
2477 Tcl_FindNamespace(
2478     Tcl_Interp *interp,         /* The interpreter in which to find the
2479                                  * namespace. */
2480     const char *name,           /* Namespace name. If it starts with "::",
2481                                  * will be looked up in global namespace.
2482                                  * Else, looked up first in contextNsPtr
2483                                  * (current namespace if contextNsPtr is
2484                                  * NULL), then in global namespace. */
2485     Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
2486                                  * if the name starts with "::". Otherwise,
2487                                  * points to namespace in which to resolve
2488                                  * name; if NULL, look up name in the current
2489                                  * namespace. */
2490     int flags)          /* Flags controlling namespace lookup: an OR'd
2491                                  * combination of TCL_GLOBAL_ONLY and
2492                                  * TCL_LEAVE_ERR_MSG flags. */
2493 {
2494     Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
2495     const char *dummy;
2496
2497     /*
2498      * Find the namespace(s) that contain the specified namespace name. Add
2499      * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its
2500      * last component, a namespace.
2501      */
2502
2503     TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
2504             flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
2505
2506     if (nsPtr != NULL) {
2507         return (Tcl_Namespace *) nsPtr;
2508     }
2509
2510     if (flags & TCL_LEAVE_ERR_MSG) {
2511         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2512                 "unknown namespace \"%s\"", name));
2513         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
2514     }
2515     return NULL;
2516 }
2517 \f
2518 /*
2519  *----------------------------------------------------------------------
2520  *
2521  * Tcl_FindCommand --
2522  *
2523  *      Searches for a command.
2524  *
2525  * Results:
2526  *      Returns a token for the command if it is found. Otherwise, if it can't
2527  *      be found or there is an error, returns NULL and leaves an error
2528  *      message in the interpreter's result object if "flags" contains
2529  *      TCL_LEAVE_ERR_MSG.
2530  *
2531  * Side effects:
2532  *      None.
2533  *
2534  *----------------------------------------------------------------------
2535  */
2536
2537 Tcl_Command
2538 Tcl_FindCommand(
2539     Tcl_Interp *interp,         /* The interpreter in which to find the
2540                                  * command and to report errors. */
2541     const char *name,           /* Command's name. If it starts with "::",
2542                                  * will be looked up in global namespace.
2543                                  * Else, looked up first in contextNsPtr
2544                                  * (current namespace if contextNsPtr is
2545                                  * NULL), then in global namespace. */
2546     Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set.
2547                                  * Otherwise, points to namespace in which to
2548                                  * resolve name. If NULL, look up name in the
2549                                  * current namespace. */
2550     int flags)                  /* An OR'd combination of flags:
2551                                  * TCL_GLOBAL_ONLY (look up name only in
2552                                  * global namespace), TCL_NAMESPACE_ONLY (look
2553                                  * up only in contextNsPtr, or the current
2554                                  * namespace if contextNsPtr is NULL), and
2555                                  * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
2556                                  * and TCL_NAMESPACE_ONLY are given,
2557                                  * TCL_GLOBAL_ONLY is ignored. */
2558 {
2559     Interp *iPtr = (Interp *) interp;
2560     Namespace *cxtNsPtr;
2561     Tcl_HashEntry *entryPtr;
2562     Command *cmdPtr;
2563     const char *simpleName;
2564     int result;
2565
2566     /*
2567      * If this namespace has a command resolver, then give it first crack at
2568      * the command resolution. If the interpreter has any command resolvers,
2569      * consult them next. The command resolver functions may return a
2570      * Tcl_Command value, they may signal to continue onward, or they may
2571      * signal an error.
2572      */
2573
2574     if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) {
2575         cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2576     } else if (contextNsPtr != NULL) {
2577         cxtNsPtr = (Namespace *) contextNsPtr;
2578     } else {
2579         cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
2580     }
2581
2582     if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
2583         ResolverScheme *resPtr = iPtr->resolverPtr;
2584         Tcl_Command cmd;
2585
2586         if (cxtNsPtr->cmdResProc) {
2587             result = cxtNsPtr->cmdResProc(interp, name,
2588                     (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
2589         } else {
2590             result = TCL_CONTINUE;
2591         }
2592
2593         while (result == TCL_CONTINUE && resPtr) {
2594             if (resPtr->cmdResProc) {
2595                 result = resPtr->cmdResProc(interp, name,
2596                         (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
2597             }
2598             resPtr = resPtr->nextPtr;
2599         }
2600
2601         if (result == TCL_OK) {
2602             ((Command *)cmd)->flags |= CMD_VIA_RESOLVER;
2603             return cmd;
2604
2605         } else if (result != TCL_CONTINUE) {
2606             return NULL;
2607         }
2608     }
2609
2610     /*
2611      * Find the namespace(s) that contain the command.
2612      */
2613
2614     cmdPtr = NULL;
2615     if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
2616             && !(flags & TCL_NAMESPACE_ONLY)) {
2617         int i;
2618         Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
2619
2620         (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
2621                 TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2622                 &simpleName);
2623         if ((realNsPtr != NULL) && (simpleName != NULL)) {
2624             if ((cxtNsPtr == realNsPtr)
2625                     || !(realNsPtr->flags & NS_DYING)) {
2626                 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2627                 if (entryPtr != NULL) {
2628                     cmdPtr = Tcl_GetHashValue(entryPtr);
2629                 }
2630             }
2631         }
2632
2633         /*
2634          * Next, check along the path.
2635          */
2636
2637         for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
2638             pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
2639             if (pathNsPtr == NULL) {
2640                 continue;
2641             }
2642             (void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
2643                     TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2644                     &simpleName);
2645             if ((realNsPtr != NULL) && (simpleName != NULL)
2646                     && !(realNsPtr->flags & NS_DYING)) {
2647                 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2648                 if (entryPtr != NULL) {
2649                     cmdPtr = Tcl_GetHashValue(entryPtr);
2650                 }
2651             }
2652         }
2653
2654         /*
2655          * If we've still not found the command, look in the global namespace
2656          * as a last resort.
2657          */
2658
2659         if (cmdPtr == NULL) {
2660             (void) TclGetNamespaceForQualName(interp, name, NULL,
2661                     TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2662                     &simpleName);
2663             if ((realNsPtr != NULL) && (simpleName != NULL)
2664                     && !(realNsPtr->flags & NS_DYING)) {
2665                 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2666                 if (entryPtr != NULL) {
2667                     cmdPtr = Tcl_GetHashValue(entryPtr);
2668                 }
2669             }
2670         }
2671     } else {
2672         Namespace *nsPtr[2];
2673         int search;
2674
2675         TclGetNamespaceForQualName(interp, name, cxtNsPtr,
2676                 flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
2677
2678         /*
2679          * Look for the command in the command table of its namespace. Be sure
2680          * to check both possible search paths: from the specified namespace
2681          * context and from the global namespace.
2682          */
2683
2684         for (search = 0;  (search < 2) && (cmdPtr == NULL);  search++) {
2685             if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
2686                 entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
2687                         simpleName);
2688                 if (entryPtr != NULL) {
2689                     cmdPtr = Tcl_GetHashValue(entryPtr);
2690                 }
2691             }
2692         }
2693     }
2694
2695     if (cmdPtr != NULL) {
2696         cmdPtr->flags  &= ~CMD_VIA_RESOLVER;
2697         return (Tcl_Command) cmdPtr;
2698     }
2699
2700     if (flags & TCL_LEAVE_ERR_MSG) {
2701         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2702                 "unknown command \"%s\"", name));
2703         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
2704     }
2705     return NULL;
2706 }
2707 \f
2708 /*
2709  *----------------------------------------------------------------------
2710  *
2711  * TclResetShadowedCmdRefs --
2712  *
2713  *      Called when a command is added to a namespace to check for existing
2714  *      command references that the new command may invalidate. Consider the
2715  *      following cases that could happen when you add a command "foo" to a
2716  *      namespace "b":
2717  *         1. It could shadow a command named "foo" at the global scope. If
2718  *            it does, all command references in the namespace "b" are
2719  *            suspect.
2720  *         2. Suppose the namespace "b" resides in a namespace "a". Then to
2721  *            "a" the new command "b::foo" could shadow another command
2722  *            "b::foo" in the global namespace. If so, then all command
2723  *            references in "a" * are suspect.
2724  *      The same checks are applied to all parent namespaces, until we reach
2725  *      the global :: namespace.
2726  *
2727  * Results:
2728  *      None.
2729  *
2730  * Side effects:
2731  *      If the new command shadows an existing command, the cmdRefEpoch
2732  *      counter is incremented in each namespace that sees the shadow. This
2733  *      invalidates all command references that were previously cached in that
2734  *      namespace. The next time the commands are used, they are resolved from
2735  *      scratch.
2736  *
2737  *----------------------------------------------------------------------
2738  */
2739
2740 void
2741 TclResetShadowedCmdRefs(
2742     Tcl_Interp *interp,         /* Interpreter containing the new command. */
2743     Command *newCmdPtr)         /* Points to the new command. */
2744 {
2745     char *cmdName;
2746     Tcl_HashEntry *hPtr;
2747     Namespace *nsPtr;
2748     Namespace *trailNsPtr, *shadowNsPtr;
2749     Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2750     int found, i;
2751     int trailFront = -1;
2752     int trailSize = 5;          /* Formerly NUM_TRAIL_ELEMS. */
2753     Namespace **trailPtr = TclStackAlloc(interp,
2754             trailSize * sizeof(Namespace *));
2755
2756     /*
2757      * Start at the namespace containing the new command, and work up through
2758      * the list of parents. Stop just before the global namespace, since the
2759      * global namespace can't "shadow" its own entries.
2760      *
2761      * The namespace "trail" list we build consists of the names of each
2762      * namespace that encloses the new command, in order from outermost to
2763      * innermost: for example, "a" then "b". Each iteration of this loop
2764      * eventually extends the trail upwards by one namespace, nsPtr. We use
2765      * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
2766      * now-invalid cached command references. This will happen if nsPtr
2767      * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
2768      * there is a identically-named sequence of child namespaces starting from
2769      * :: (e.g. "::b") whose tail namespace contains a command also named
2770      * cmdName.
2771      */
2772
2773     cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
2774     for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
2775             nsPtr=nsPtr->parentPtr) {
2776         /*
2777          * Find the maximal sequence of child namespaces contained in nsPtr
2778          * such that there is a identically-named sequence of child namespaces
2779          * starting from ::. shadowNsPtr will be the tail of this sequence, or
2780          * the deepest namespace under :: that might contain a command now
2781          * shadowed by cmdName. We check below if shadowNsPtr actually
2782          * contains a command cmdName.
2783          */
2784
2785         found = 1;
2786         shadowNsPtr = globalNsPtr;
2787
2788         for (i = trailFront;  i >= 0;  i--) {
2789             trailNsPtr = trailPtr[i];
2790 #ifndef BREAK_NAMESPACE_COMPAT
2791             hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
2792                     trailNsPtr->name);
2793 #else
2794             if (shadowNsPtr->childTablePtr != NULL) {
2795                 hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
2796                         trailNsPtr->name);
2797             } else {
2798                 hPtr = NULL;
2799             }
2800 #endif
2801             if (hPtr != NULL) {
2802                 shadowNsPtr = Tcl_GetHashValue(hPtr);
2803             } else {
2804                 found = 0;
2805                 break;
2806             }
2807         }
2808
2809         /*
2810          * If shadowNsPtr contains a command named cmdName, we invalidate all
2811          * of the command refs cached in nsPtr. As a boundary case,
2812          * shadowNsPtr is initially :: and we check for case 1. above.
2813          */
2814
2815         if (found) {
2816             hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
2817             if (hPtr != NULL) {
2818                 nsPtr->cmdRefEpoch++;
2819                 TclInvalidateNsPath(nsPtr);
2820
2821                 /*
2822                  * If the shadowed command was compiled to bytecodes, we
2823                  * invalidate all the bytecodes in nsPtr, to force a new
2824                  * compilation. We use the resolverEpoch to signal the need
2825                  * for a fresh compilation of every bytecode.
2826                  */
2827
2828                 if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL){
2829                     nsPtr->resolverEpoch++;
2830                 }
2831             }
2832         }
2833
2834         /*
2835          * Insert nsPtr at the front of the trail list: i.e., at the end of
2836          * the trailPtr array.
2837          */
2838
2839         trailFront++;
2840         if (trailFront == trailSize) {
2841             int newSize = 2 * trailSize;
2842
2843             trailPtr = TclStackRealloc(interp, trailPtr,
2844                     newSize * sizeof(Namespace *));
2845             trailSize = newSize;
2846         }
2847         trailPtr[trailFront] = nsPtr;
2848     }
2849     TclStackFree(interp, trailPtr);
2850 }
2851 \f
2852 /*
2853  *----------------------------------------------------------------------
2854  *
2855  * TclGetNamespaceFromObj, GetNamespaceFromObj --
2856  *
2857  *      Gets the namespace specified by the name in a Tcl_Obj.
2858  *
2859  * Results:
2860  *      Returns TCL_OK if the namespace was resolved successfully, and stores
2861  *      a pointer to the namespace in the location specified by nsPtrPtr. If
2862  *      the namespace can't be found, or anything else goes wrong, this
2863  *      function returns TCL_ERROR and writes an error message to interp,
2864  *      if non-NULL.
2865  *
2866  * Side effects:
2867  *      May update the internal representation for the object, caching the
2868  *      namespace reference. The next time this function is called, the
2869  *      namespace value can be found quickly.
2870  *
2871  *----------------------------------------------------------------------
2872  */
2873
2874 int
2875 TclGetNamespaceFromObj(
2876     Tcl_Interp *interp,         /* The current interpreter. */
2877     Tcl_Obj *objPtr,            /* The object to be resolved as the name of a
2878                                  * namespace. */
2879     Tcl_Namespace **nsPtrPtr)   /* Result namespace pointer goes here. */
2880 {
2881     if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) {
2882         const char *name = TclGetString(objPtr);
2883
2884         if ((name[0] == ':') && (name[1] == ':')) {
2885             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2886                     "namespace \"%s\" not found", name));
2887         } else {
2888             /*
2889              * Get the current namespace name.
2890              */
2891
2892             NamespaceCurrentCmd(NULL, interp, 1, NULL);
2893             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2894                     "namespace \"%s\" not found in \"%s\"", name,
2895                     Tcl_GetStringResult(interp)));
2896         }
2897         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
2898         return TCL_ERROR;
2899     }
2900     return TCL_OK;
2901 }
2902
2903 static int
2904 GetNamespaceFromObj(
2905     Tcl_Interp *interp,         /* The current interpreter. */
2906     Tcl_Obj *objPtr,            /* The object to be resolved as the name of a
2907                                  * namespace. */
2908     Tcl_Namespace **nsPtrPtr)   /* Result namespace pointer goes here. */
2909 {
2910     ResolvedNsName *resNamePtr;
2911     Namespace *nsPtr, *refNsPtr;
2912
2913     if (objPtr->typePtr == &nsNameType) {
2914         /*
2915          * Check that the ResolvedNsName is still valid; avoid letting the ref
2916          * cross interps.
2917          */
2918
2919         resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
2920         nsPtr = resNamePtr->nsPtr;
2921         refNsPtr = resNamePtr->refNsPtr;
2922         if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
2923                 (!refNsPtr || ((interp == refNsPtr->interp) &&
2924                 (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
2925             *nsPtrPtr = (Tcl_Namespace *) nsPtr;
2926             return TCL_OK;
2927         }
2928     }
2929     if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
2930         resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
2931         *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
2932         return TCL_OK;
2933     }
2934     return TCL_ERROR;
2935 }
2936 \f
2937 /*
2938  *----------------------------------------------------------------------
2939  *
2940  * TclInitNamespaceCmd --
2941  *
2942  *      This function is called to create the "namespace" Tcl command. See the
2943  *      user documentation for details on what it does.
2944  *
2945  * Results:
2946  *      Handle for the namespace command, or NULL on failure.
2947  *
2948  * Side effects:
2949  *      none
2950  *
2951  *----------------------------------------------------------------------
2952  */
2953
2954 Tcl_Command
2955 TclInitNamespaceCmd(
2956     Tcl_Interp *interp)         /* Current interpreter. */
2957 {
2958     return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap);
2959 }
2960 \f
2961 /*
2962  *----------------------------------------------------------------------
2963  *
2964  * NamespaceChildrenCmd --
2965  *
2966  *      Invoked to implement the "namespace children" command that returns a
2967  *      list containing the fully-qualified names of the child namespaces of a
2968  *      given namespace. Handles the following syntax:
2969  *
2970  *          namespace children ?name? ?pattern?
2971  *
2972  * Results:
2973  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
2974  *
2975  * Side effects:
2976  *      Returns a result in the interpreter's result object. If anything goes
2977  *      wrong, the result is an error message.
2978  *
2979  *----------------------------------------------------------------------
2980  */
2981
2982 static int
2983 NamespaceChildrenCmd(
2984     ClientData dummy,           /* Not used. */
2985     Tcl_Interp *interp,         /* Current interpreter. */
2986     int objc,                   /* Number of arguments. */
2987     Tcl_Obj *const objv[])      /* Argument objects. */
2988 {
2989     Tcl_Namespace *namespacePtr;
2990     Namespace *nsPtr, *childNsPtr;
2991     Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2992     const char *pattern = NULL;
2993     Tcl_DString buffer;
2994     Tcl_HashEntry *entryPtr;
2995     Tcl_HashSearch search;
2996     Tcl_Obj *listPtr, *elemPtr;
2997
2998     /*
2999      * Get a pointer to the specified namespace, or the current namespace.
3000      */
3001
3002     if (objc == 1) {
3003         nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3004     } else if ((objc == 2) || (objc == 3)) {
3005         if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){
3006             return TCL_ERROR;
3007         }
3008         nsPtr = (Namespace *) namespacePtr;
3009     } else {
3010         Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?");
3011         return TCL_ERROR;
3012     }
3013
3014     /*
3015      * Get the glob-style pattern, if any, used to narrow the search.
3016      */
3017
3018     Tcl_DStringInit(&buffer);
3019     if (objc == 3) {
3020         const char *name = TclGetString(objv[2]);
3021
3022         if ((*name == ':') && (*(name+1) == ':')) {
3023             pattern = name;
3024         } else {
3025             Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
3026             if (nsPtr != globalNsPtr) {
3027                 TclDStringAppendLiteral(&buffer, "::");
3028             }
3029             Tcl_DStringAppend(&buffer, name, -1);
3030             pattern = Tcl_DStringValue(&buffer);
3031         }
3032     }
3033
3034     /*
3035      * Create a list containing the full names of all child namespaces whose
3036      * names match the specified pattern, if any.
3037      */
3038
3039     listPtr = Tcl_NewListObj(0, NULL);
3040     if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
3041         unsigned int length = strlen(nsPtr->fullName);
3042
3043         if (strncmp(pattern, nsPtr->fullName, length) != 0) {
3044             goto searchDone;
3045         }
3046         if (
3047 #ifndef BREAK_NAMESPACE_COMPAT
3048             Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
3049 #else
3050             nsPtr->childTablePtr != NULL &&
3051             Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
3052 #endif
3053         ) {
3054             Tcl_ListObjAppendElement(interp, listPtr,
3055                     Tcl_NewStringObj(pattern, -1));
3056         }
3057         goto searchDone;
3058     }
3059 #ifndef BREAK_NAMESPACE_COMPAT
3060     entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
3061 #else
3062     if (nsPtr->childTablePtr == NULL) {
3063         goto searchDone;
3064     }
3065     entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
3066 #endif
3067     while (entryPtr != NULL) {
3068         childNsPtr = Tcl_GetHashValue(entryPtr);
3069         if ((pattern == NULL)
3070                 || Tcl_StringMatch(childNsPtr->fullName, pattern)) {
3071             elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
3072             Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
3073         }
3074         entryPtr = Tcl_NextHashEntry(&search);
3075     }
3076
3077   searchDone:
3078     Tcl_SetObjResult(interp, listPtr);
3079     Tcl_DStringFree(&buffer);
3080     return TCL_OK;
3081 }
3082 \f
3083 /*
3084  *----------------------------------------------------------------------
3085  *
3086  * NamespaceCodeCmd --
3087  *
3088  *      Invoked to implement the "namespace code" command to capture the
3089  *      namespace context of a command. Handles the following syntax:
3090  *
3091  *          namespace code arg
3092  *
3093  *      Here "arg" can be a list. "namespace code arg" produces a result
3094  *      equivalent to that produced by the command
3095  *
3096  *          list ::namespace inscope [namespace current] $arg
3097  *
3098  *      However, if "arg" is itself a scoped value starting with "::namespace
3099  *      inscope", then the result is just "arg".
3100  *
3101  * Results:
3102  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3103  *
3104  * Side effects:
3105  *      If anything goes wrong, this function returns an error message as the
3106  *      result in the interpreter's result object.
3107  *
3108  *----------------------------------------------------------------------
3109  */
3110
3111 static int
3112 NamespaceCodeCmd(
3113     ClientData dummy,           /* Not used. */
3114     Tcl_Interp *interp,         /* Current interpreter. */
3115     int objc,                   /* Number of arguments. */
3116     Tcl_Obj *const objv[])      /* Argument objects. */
3117 {
3118     Namespace *currNsPtr;
3119     Tcl_Obj *listPtr, *objPtr;
3120     const char *arg;
3121     int length;
3122
3123     if (objc != 2) {
3124         Tcl_WrongNumArgs(interp, 1, objv, "arg");
3125         return TCL_ERROR;
3126     }
3127
3128     /*
3129      * If "arg" is already a scoped value, then return it directly.
3130      * Take care to only check for scoping in precisely the style that
3131      * [::namespace code] generates it.  Anything more forgiving can have
3132      * the effect of failing in namespaces that contain their own custom
3133      " "namespace" command.  [Bug 3202171].
3134      */
3135
3136     arg = TclGetStringFromObj(objv[1], &length);
3137     if (*arg==':' && length > 20
3138             && strncmp(arg, "::namespace inscope ", 20) == 0) {
3139         Tcl_SetObjResult(interp, objv[1]);
3140         return TCL_OK;
3141     }
3142
3143     /*
3144      * Otherwise, construct a scoped command by building a list with
3145      * "namespace inscope", the full name of the current namespace, and the
3146      * argument "arg". By constructing a list, we ensure that scoped commands
3147      * are interpreted properly when they are executed later, by the
3148      * "namespace inscope" command.
3149      */
3150
3151     TclNewObj(listPtr);
3152     TclNewLiteralStringObj(objPtr, "::namespace");
3153     Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3154     TclNewLiteralStringObj(objPtr, "inscope");
3155     Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3156
3157     currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3158     if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
3159         TclNewLiteralStringObj(objPtr, "::");
3160     } else {
3161         objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
3162     }
3163     Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3164
3165     Tcl_ListObjAppendElement(interp, listPtr, objv[1]);
3166
3167     Tcl_SetObjResult(interp, listPtr);
3168     return TCL_OK;
3169 }
3170 \f
3171 /*
3172  *----------------------------------------------------------------------
3173  *
3174  * NamespaceCurrentCmd --
3175  *
3176  *      Invoked to implement the "namespace current" command which returns the
3177  *      fully-qualified name of the current namespace. Handles the following
3178  *      syntax:
3179  *
3180  *          namespace current
3181  *
3182  * Results:
3183  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3184  *
3185  * Side effects:
3186  *      Returns a result in the interpreter's result object. If anything goes
3187  *      wrong, the result is an error message.
3188  *
3189  *----------------------------------------------------------------------
3190  */
3191
3192 static int
3193 NamespaceCurrentCmd(
3194     ClientData dummy,           /* Not used. */
3195     Tcl_Interp *interp,         /* Current interpreter. */
3196     int objc,                   /* Number of arguments. */
3197     Tcl_Obj *const objv[])      /* Argument objects. */
3198 {
3199     Namespace *currNsPtr;
3200
3201     if (objc != 1) {
3202         Tcl_WrongNumArgs(interp, 1, objv, NULL);
3203         return TCL_ERROR;
3204     }
3205
3206     /*
3207      * The "real" name of the global namespace ("::") is the null string, but
3208      * we return "::" for it as a convenience to programmers. Note that "" and
3209      * "::" are treated as synonyms by the namespace code so that it is still
3210      * easy to do things like:
3211      *
3212      *    namespace [namespace current]::bar { ... }
3213      */
3214
3215     currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3216     if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
3217         Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
3218     } else {
3219         Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1));
3220     }
3221     return TCL_OK;
3222 }
3223 \f
3224 /*
3225  *----------------------------------------------------------------------
3226  *
3227  * NamespaceDeleteCmd --
3228  *
3229  *      Invoked to implement the "namespace delete" command to delete
3230  *      namespace(s). Handles the following syntax:
3231  *
3232  *          namespace delete ?name name...?
3233  *
3234  *      Each name identifies a namespace. It may include a sequence of
3235  *      namespace qualifiers separated by "::"s. If a namespace is found, it
3236  *      is deleted: all variables and procedures contained in that namespace
3237  *      are deleted. If that namespace is being used on the call stack, it is
3238  *      kept alive (but logically deleted) until it is removed from the call
3239  *      stack: that is, it can no longer be referenced by name but any
3240  *      currently executing procedure that refers to it is allowed to do so
3241  *      until the procedure returns. If the namespace can't be found, this
3242  *      function returns an error. If no namespaces are specified, this
3243  *      command does nothing.
3244  *
3245  * Results:
3246  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3247  *
3248  * Side effects:
3249  *      Deletes the specified namespaces. If anything goes wrong, this
3250  *      function returns an error message in the interpreter's result object.
3251  *
3252  *----------------------------------------------------------------------
3253  */
3254
3255 static int
3256 NamespaceDeleteCmd(
3257     ClientData dummy,           /* Not used. */
3258     Tcl_Interp *interp,         /* Current interpreter. */
3259     int objc,                   /* Number of arguments. */
3260     Tcl_Obj *const objv[])      /* Argument objects. */
3261 {
3262     Tcl_Namespace *namespacePtr;
3263     const char *name;
3264     int i;
3265
3266     if (objc < 1) {
3267         Tcl_WrongNumArgs(interp, 1, objv, "?name name...?");
3268         return TCL_ERROR;
3269     }
3270
3271     /*
3272      * Destroying one namespace may cause another to be destroyed. Break this
3273      * into two passes: first check to make sure that all namespaces on the
3274      * command line are valid, and report any errors.
3275      */
3276
3277     for (i = 1;  i < objc;  i++) {
3278         name = TclGetString(objv[i]);
3279         namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
3280         if ((namespacePtr == NULL)
3281                 || (((Namespace *) namespacePtr)->flags & NS_KILLED)) {
3282             Tcl_SetObjResult(interp, Tcl_ObjPrintf(
3283                     "unknown namespace \"%s\" in namespace delete command",
3284                     TclGetString(objv[i])));
3285             Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
3286                     TclGetString(objv[i]), NULL);
3287             return TCL_ERROR;
3288         }
3289     }
3290
3291     /*
3292      * Okay, now delete each namespace.
3293      */
3294
3295     for (i = 1;  i < objc;  i++) {
3296         name = TclGetString(objv[i]);
3297         namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0);
3298         if (namespacePtr) {
3299             Tcl_DeleteNamespace(namespacePtr);
3300         }
3301     }
3302     return TCL_OK;
3303 }
3304 \f
3305 /*
3306  *----------------------------------------------------------------------
3307  *
3308  * NamespaceEvalCmd --
3309  *
3310  *      Invoked to implement the "namespace eval" command. Executes commands
3311  *      in a namespace. If the namespace does not already exist, it is
3312  *      created. Handles the following syntax:
3313  *
3314  *          namespace eval name arg ?arg...?
3315  *
3316  *      If more than one arg argument is specified, the command that is
3317  *      executed is the result of concatenating the arguments together with a
3318  *      space between each argument.
3319  *
3320  * Results:
3321  *      Returns TCL_OK if the namespace is found and the commands are executed
3322  *      successfully. Returns TCL_ERROR if anything goes wrong.
3323  *
3324  * Side effects:
3325  *      Returns the result of the command in the interpreter's result object.
3326  *      If anything goes wrong, this function returns an error message as the
3327  *      result.
3328  *
3329  *----------------------------------------------------------------------
3330  */
3331
3332 static int
3333 NamespaceEvalCmd(
3334     ClientData clientData,      /* Arbitrary value passed to cmd. */
3335     Tcl_Interp *interp,         /* Current interpreter. */
3336     int objc,                   /* Number of arguments. */
3337     Tcl_Obj *const objv[])      /* Argument objects. */
3338 {
3339     return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
3340             objv);
3341 }
3342
3343 static int
3344 NRNamespaceEvalCmd(
3345     ClientData dummy,           /* Not used. */
3346     Tcl_Interp *interp,         /* Current interpreter. */
3347     int objc,                   /* Number of arguments. */
3348     Tcl_Obj *const objv[])      /* Argument objects. */
3349 {
3350     Interp *iPtr = (Interp *) interp;
3351     CmdFrame *invoker;
3352     int word;
3353     Tcl_Namespace *namespacePtr;
3354     CallFrame *framePtr, **framePtrPtr;
3355     Tcl_Obj *objPtr;
3356     int result;
3357
3358     if (objc < 3) {
3359         Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
3360         return TCL_ERROR;
3361     }
3362
3363     /*
3364      * Try to resolve the namespace reference, caching the result in the
3365      * namespace object along the way.
3366      */
3367
3368     result = GetNamespaceFromObj(interp, objv[1], &namespacePtr);
3369
3370     /*
3371      * If the namespace wasn't found, try to create it.
3372      */
3373
3374     if (result == TCL_ERROR) {
3375         const char *name = TclGetString(objv[1]);
3376
3377         namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL);
3378         if (namespacePtr == NULL) {
3379             return TCL_ERROR;
3380         }
3381     }
3382
3383     /*
3384      * Make the specified namespace the current namespace and evaluate the
3385      * command(s).
3386      */
3387
3388     /* This is needed to satisfy GCC 3.3's strict aliasing rules */
3389     framePtrPtr = &framePtr;
3390     (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
3391             namespacePtr, /*isProcCallFrame*/ 0);
3392
3393     framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
3394
3395     if (objc == 3) {
3396         /*
3397          * TIP #280: Make actual argument location available to eval'd script.
3398          */
3399
3400         objPtr = objv[2];
3401         invoker = iPtr->cmdFramePtr;
3402         word = 3;
3403         TclArgumentGet(interp, objPtr, &invoker, &word);
3404     } else {
3405         /*
3406          * More than one argument: concatenate them together with spaces
3407          * between, then evaluate the result. Tcl_EvalObjEx will delete the
3408          * object when it decrements its refcount after eval'ing it.
3409          */
3410
3411         objPtr = Tcl_ConcatObj(objc-2, objv+2);
3412         invoker = NULL;
3413         word = 0;
3414     }
3415
3416     /*
3417      * TIP #280: Make invoking context available to eval'd script.
3418      */
3419
3420     TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "eval",
3421             NULL, NULL);
3422     return TclNREvalObjEx(interp, objPtr, 0, invoker, word);
3423 }
3424
3425 static int
3426 NsEval_Callback(
3427     ClientData data[],
3428     Tcl_Interp *interp,
3429     int result)
3430 {
3431     Tcl_Namespace *namespacePtr = data[0];
3432
3433     if (result == TCL_ERROR) {
3434         int length = strlen(namespacePtr->fullName);
3435         int limit = 200;
3436         int overflow = (length > limit);
3437         char *cmd = data[1];
3438
3439         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
3440                 "\n    (in namespace %s \"%.*s%s\" script line %d)",
3441                 cmd,
3442                 (overflow ? limit : length), namespacePtr->fullName,
3443                 (overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
3444     }
3445
3446     /*
3447      * Restore the previous "current" namespace.
3448      */
3449
3450     TclPopStackFrame(interp);
3451     return result;
3452 }
3453 \f
3454 /*
3455  *----------------------------------------------------------------------
3456  *
3457  * NamespaceExistsCmd --
3458  *
3459  *      Invoked to implement the "namespace exists" command that returns true
3460  *      if the given namespace currently exists, and false otherwise. Handles
3461  *      the following syntax:
3462  *
3463  *          namespace exists name
3464  *
3465  * Results:
3466  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3467  *
3468  * Side effects:
3469  *      Returns a result in the interpreter's result object. If anything goes
3470  *      wrong, the result is an error message.
3471  *
3472  *----------------------------------------------------------------------
3473  */
3474
3475 static int
3476 NamespaceExistsCmd(
3477     ClientData dummy,           /* Not used. */
3478     Tcl_Interp *interp,         /* Current interpreter. */
3479     int objc,                   /* Number of arguments. */
3480     Tcl_Obj *const objv[])      /* Argument objects. */
3481 {
3482     Tcl_Namespace *namespacePtr;
3483
3484     if (objc != 2) {
3485         Tcl_WrongNumArgs(interp, 1, objv, "name");
3486         return TCL_ERROR;
3487     }
3488
3489     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
3490             GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK));
3491     return TCL_OK;
3492 }
3493 \f
3494 /*
3495  *----------------------------------------------------------------------
3496  *
3497  * NamespaceExportCmd --
3498  *
3499  *      Invoked to implement the "namespace export" command that specifies
3500  *      which commands are exported from a namespace. The exported commands
3501  *      are those that can be imported into another namespace using "namespace
3502  *      import". Both commands defined in a namespace and commands the
3503  *      namespace has imported can be exported by a namespace. This command
3504  *      has the following syntax:
3505  *
3506  *          namespace export ?-clear? ?pattern pattern...?
3507  *
3508  *      Each pattern may contain "string match"-style pattern matching special
3509  *      characters, but the pattern may not include any namespace qualifiers:
3510  *      that is, the pattern must specify commands in the current (exporting)
3511  *      namespace. The specified patterns are appended onto the namespace's
3512  *      list of export patterns.
3513  *
3514  *      To reset the namespace's export pattern list, specify the "-clear"
3515  *      flag.
3516  *
3517  *      If there are no export patterns and the "-clear" flag isn't given,
3518  *      this command returns the namespace's current export list.
3519  *
3520  * Results:
3521  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3522  *
3523  * Side effects:
3524  *      Returns a result in the interpreter's result object. If anything goes
3525  *      wrong, the result is an error message.
3526  *
3527  *----------------------------------------------------------------------
3528  */
3529
3530 static int
3531 NamespaceExportCmd(
3532     ClientData dummy,           /* Not used. */
3533     Tcl_Interp *interp,         /* Current interpreter. */
3534     int objc,                   /* Number of arguments. */
3535     Tcl_Obj *const objv[])      /* Argument objects. */
3536 {
3537     int firstArg, i;
3538
3539     if (objc < 1) {
3540         Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
3541         return TCL_ERROR;
3542     }
3543
3544     /*
3545      * If no pattern arguments are given, and "-clear" isn't specified, return
3546      * the namespace's current export pattern list.
3547      */
3548
3549     if (objc == 1) {
3550         Tcl_Obj *listPtr;
3551
3552         TclNewObj(listPtr);
3553         (void) Tcl_AppendExportList(interp, NULL, listPtr);
3554         Tcl_SetObjResult(interp, listPtr);
3555         return TCL_OK;
3556     }
3557
3558     /*
3559      * Process the optional "-clear" argument.
3560      */
3561
3562     firstArg = 1;
3563     if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
3564         Tcl_Export(interp, NULL, "::", 1);
3565         Tcl_ResetResult(interp);
3566         firstArg++;
3567     }
3568
3569     /*
3570      * Add each pattern to the namespace's export pattern list.
3571      */
3572
3573     for (i = firstArg;  i < objc;  i++) {
3574         int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
3575         if (result != TCL_OK) {
3576             return result;
3577         }
3578     }
3579     return TCL_OK;
3580 }
3581 \f
3582 /*
3583  *----------------------------------------------------------------------
3584  *
3585  * NamespaceForgetCmd --
3586  *
3587  *      Invoked to implement the "namespace forget" command to remove imported
3588  *      commands from a namespace. Handles the following syntax:
3589  *
3590  *          namespace forget ?pattern pattern...?
3591  *
3592  *      Each pattern is a name like "foo::*" or "a::b::x*". That is, the
3593  *      pattern may include the special pattern matching characters recognized
3594  *      by the "string match" command, but only in the command name at the end
3595  *      of the qualified name; the special pattern characters may not appear
3596  *      in a namespace name. All of the commands that match that pattern are
3597  *      checked to see if they have an imported command in the current
3598  *      namespace that refers to the matched command. If there is an alias, it
3599  *      is removed.
3600  *
3601  * Results:
3602  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3603  *
3604  * Side effects:
3605  *      Imported commands are removed from the current namespace. If anything
3606  *      goes wrong, this function returns an error message in the
3607  *      interpreter's result object.
3608  *
3609  *----------------------------------------------------------------------
3610  */
3611
3612 static int
3613 NamespaceForgetCmd(
3614     ClientData dummy,           /* Not used. */
3615     Tcl_Interp *interp,         /* Current interpreter. */
3616     int objc,                   /* Number of arguments. */
3617     Tcl_Obj *const objv[])      /* Argument objects. */
3618 {
3619     const char *pattern;
3620     int i, result;
3621
3622     if (objc < 1) {
3623         Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?");
3624         return TCL_ERROR;
3625     }
3626
3627     for (i = 1;  i < objc;  i++) {
3628         pattern = TclGetString(objv[i]);
3629         result = Tcl_ForgetImport(interp, NULL, pattern);
3630         if (result != TCL_OK) {
3631             return result;
3632         }
3633     }
3634     return TCL_OK;
3635 }
3636 \f
3637 /*
3638  *----------------------------------------------------------------------
3639  *
3640  * NamespaceImportCmd --
3641  *
3642  *      Invoked to implement the "namespace import" command that imports
3643  *      commands into a namespace. Handles the following syntax:
3644  *
3645  *          namespace import ?-force? ?pattern pattern...?
3646  *
3647  *      Each pattern is a namespace-qualified name like "foo::*", "a::b::x*",
3648  *      or "bar::p". That is, the pattern may include the special pattern
3649  *      matching characters recognized by the "string match" command, but only
3650  *      in the command name at the end of the qualified name; the special
3651  *      pattern characters may not appear in a namespace name. All of the
3652  *      commands that match the pattern and which are exported from their
3653  *      namespace are made accessible from the current namespace context. This
3654  *      is done by creating a new "imported command" in the current namespace
3655  *      that points to the real command in its original namespace; when the
3656  *      imported command is called, it invokes the real command.
3657  *
3658  *      If an imported command conflicts with an existing command, it is
3659  *      treated as an error. But if the "-force" option is included, then
3660  *      existing commands are overwritten by the imported commands.
3661  *
3662  *      If there are no pattern arguments and the "-force" flag isn't given,
3663  *      this command returns the list of commands currently imported in
3664  *      the current namespace.
3665  *
3666  * Results:
3667  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3668  *
3669  * Side effects:
3670  *      Adds imported commands to the current namespace. If anything goes
3671  *      wrong, this function returns an error message in the interpreter's
3672  *      result object.
3673  *
3674  *----------------------------------------------------------------------
3675  */
3676
3677 static int
3678 NamespaceImportCmd(
3679     ClientData dummy,           /* Not used. */
3680     Tcl_Interp *interp,         /* Current interpreter. */
3681     int objc,                   /* Number of arguments. */
3682     Tcl_Obj *const objv[])      /* Argument objects. */
3683 {
3684     int allowOverwrite = 0;
3685     const char *string, *pattern;
3686     int i, result;
3687     int firstArg;
3688
3689     if (objc < 1) {
3690         Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
3691         return TCL_ERROR;
3692     }
3693
3694     /*
3695      * Skip over the optional "-force" as the first argument.
3696      */
3697
3698     firstArg = 1;
3699     if (firstArg < objc) {
3700         string = TclGetString(objv[firstArg]);
3701         if ((*string == '-') && (strcmp(string, "-force") == 0)) {
3702             allowOverwrite = 1;
3703             firstArg++;
3704         }
3705     } else {
3706         /*
3707          * When objc == 1, command is just [namespace import]. Introspection
3708          * form to return list of imported commands.
3709          */
3710
3711         Tcl_HashEntry *hPtr;
3712         Tcl_HashSearch search;
3713         Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3714         Tcl_Obj *listPtr;
3715
3716         TclNewObj(listPtr);
3717         for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
3718                 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3719             Command *cmdPtr = Tcl_GetHashValue(hPtr);
3720
3721             if (cmdPtr->deleteProc == DeleteImportedCmd) {
3722                 Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
3723                         Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
3724             }
3725         }
3726         Tcl_SetObjResult(interp, listPtr);
3727         return TCL_OK;
3728     }
3729
3730     /*
3731      * Handle the imports for each of the patterns.
3732      */
3733
3734     for (i = firstArg;  i < objc;  i++) {
3735         pattern = TclGetString(objv[i]);
3736         result = Tcl_Import(interp, NULL, pattern, allowOverwrite);
3737         if (result != TCL_OK) {
3738             return result;
3739         }
3740     }
3741     return TCL_OK;
3742 }
3743 \f
3744 /*
3745  *----------------------------------------------------------------------
3746  *
3747  * NamespaceInscopeCmd --
3748  *
3749  *      Invoked to implement the "namespace inscope" command that executes a
3750  *      script in the context of a particular namespace. This command is not
3751  *      expected to be used directly by programmers; calls to it are generated
3752  *      implicitly when programs use "namespace code" commands to register
3753  *      callback scripts. Handles the following syntax:
3754  *
3755  *          namespace inscope name arg ?arg...?
3756  *
3757  *      The "namespace inscope" command is much like the "namespace eval"
3758  *      command except that it has lappend semantics and the namespace must
3759  *      already exist. It treats the first argument as a list, and appends any
3760  *      arguments after the first onto the end as proper list elements. For
3761  *      example,
3762  *
3763  *          namespace inscope ::foo {a b} c d e
3764  *
3765  *      is equivalent to
3766  *
3767  *          namespace eval ::foo [concat {a b} [list c d e]]
3768  *
3769  *      This lappend semantics is important because many callback scripts are
3770  *      actually prefixes.
3771  *
3772  * Results:
3773  *      Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure.
3774  *
3775  * Side effects:
3776  *      Returns a result in the Tcl interpreter's result object.
3777  *
3778  *----------------------------------------------------------------------
3779  */
3780
3781 static int
3782 NamespaceInscopeCmd(
3783     ClientData clientData,      /* Arbitrary value passed to cmd. */
3784     Tcl_Interp *interp,         /* Current interpreter. */
3785     int objc,                   /* Number of arguments. */
3786     Tcl_Obj *const objv[])      /* Argument objects. */
3787 {
3788     return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
3789             objv);
3790 }
3791
3792 static int
3793 NRNamespaceInscopeCmd(
3794     ClientData dummy,           /* Not used. */
3795     Tcl_Interp *interp,         /* Current interpreter. */
3796     int objc,                   /* Number of arguments. */
3797     Tcl_Obj *const objv[])      /* Argument objects. */
3798 {
3799     Tcl_Namespace *namespacePtr;
3800     CallFrame *framePtr, **framePtrPtr;
3801     int i;
3802     Tcl_Obj *cmdObjPtr;
3803
3804     if (objc < 3) {
3805         Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
3806         return TCL_ERROR;
3807     }
3808
3809     /*
3810      * Resolve the namespace reference.
3811      */
3812
3813     if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) {
3814         return TCL_ERROR;
3815     }
3816
3817     /*
3818      * Make the specified namespace the current namespace.
3819      */
3820
3821     framePtrPtr = &framePtr;            /* This is needed to satisfy GCC's
3822                                          * strict aliasing rules. */
3823     (void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
3824             namespacePtr, /*isProcCallFrame*/ 0);
3825
3826     framePtr->objv = TclFetchEnsembleRoot(interp, objv, objc, &framePtr->objc);
3827
3828     /*
3829      * Execute the command. If there is just one argument, just treat it as a
3830      * script and evaluate it. Otherwise, create a list from the arguments
3831      * after the first one, then concatenate the first argument and the list
3832      * of extra arguments to form the command to evaluate.
3833      */
3834
3835     if (objc == 3) {
3836         cmdObjPtr = objv[2];
3837     } else {
3838         Tcl_Obj *concatObjv[2];
3839         Tcl_Obj *listPtr;
3840
3841         listPtr = Tcl_NewListObj(0, NULL);
3842         for (i = 3;  i < objc;  i++) {
3843             if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
3844                 Tcl_DecrRefCount(listPtr);      /* Free unneeded obj. */
3845                 return TCL_ERROR;
3846             }
3847         }
3848
3849         concatObjv[0] = objv[2];
3850         concatObjv[1] = listPtr;
3851         cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
3852         Tcl_DecrRefCount(listPtr);    /* We're done with the list object. */
3853     }
3854
3855     TclNRAddCallback(interp, NsEval_Callback, namespacePtr, "inscope",
3856             NULL, NULL);
3857     return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0);
3858 }
3859 \f
3860 /*
3861  *----------------------------------------------------------------------
3862  *
3863  * NamespaceOriginCmd --
3864  *
3865  *      Invoked to implement the "namespace origin" command to return the
3866  *      fully-qualified name of the "real" command to which the specified
3867  *      "imported command" refers. Handles the following syntax:
3868  *
3869  *          namespace origin name
3870  *
3871  * Results:
3872  *      An imported command is created in an namespace when that namespace
3873  *      imports a command from another namespace. If a command is imported
3874  *      into a sequence of namespaces a, b,...,n where each successive
3875  *      namespace just imports the command from the previous namespace, this
3876  *      command returns the fully-qualified name of the original command in
3877  *      the first namespace, a. If "name" does not refer to an alias, its
3878  *      fully-qualified name is returned. The returned name is stored in the
3879  *      interpreter's result object. This function returns TCL_OK if
3880  *      successful, and TCL_ERROR if anything goes wrong.
3881  *
3882  * Side effects:
3883  *      If anything goes wrong, this function returns an error message in the
3884  *      interpreter's result object.
3885  *
3886  *----------------------------------------------------------------------
3887  */
3888
3889 static int
3890 NamespaceOriginCmd(
3891     ClientData dummy,           /* Not used. */
3892     Tcl_Interp *interp,         /* Current interpreter. */
3893     int objc,                   /* Number of arguments. */
3894     Tcl_Obj *const objv[])      /* Argument objects. */
3895 {
3896     Tcl_Command command, origCommand;
3897     Tcl_Obj *resultPtr;
3898
3899     if (objc != 2) {
3900         Tcl_WrongNumArgs(interp, 1, objv, "name");
3901         return TCL_ERROR;
3902     }
3903
3904     command = Tcl_GetCommandFromObj(interp, objv[1]);
3905     if (command == NULL) {
3906         Tcl_SetObjResult(interp, Tcl_ObjPrintf(
3907                 "invalid command name \"%s\"", TclGetString(objv[1])));
3908         Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
3909                 TclGetString(objv[1]), NULL);
3910         return TCL_ERROR;
3911     }
3912     origCommand = TclGetOriginalCommand(command);
3913     TclNewObj(resultPtr);
3914     if (origCommand == NULL) {
3915         /*
3916          * The specified command isn't an imported command. Return the
3917          * command's name qualified by the full name of the namespace it was
3918          * defined in.
3919          */
3920
3921         Tcl_GetCommandFullName(interp, command, resultPtr);
3922     } else {
3923         Tcl_GetCommandFullName(interp, origCommand, resultPtr);
3924     }
3925     Tcl_SetObjResult(interp, resultPtr);
3926     return TCL_OK;
3927 }
3928 \f
3929 /*
3930  *----------------------------------------------------------------------
3931  *
3932  * NamespaceParentCmd --
3933  *
3934  *      Invoked to implement the "namespace parent" command that returns the
3935  *      fully-qualified name of the parent namespace for a specified
3936  *      namespace. Handles the following syntax:
3937  *
3938  *          namespace parent ?name?
3939  *
3940  * Results:
3941  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3942  *
3943  * Side effects:
3944  *      Returns a result in the interpreter's result object. If anything goes
3945  *      wrong, the result is an error message.
3946  *
3947  *----------------------------------------------------------------------
3948  */
3949
3950 static int
3951 NamespaceParentCmd(
3952     ClientData dummy,           /* Not used. */
3953     Tcl_Interp *interp,         /* Current interpreter. */
3954     int objc,                   /* Number of arguments. */
3955     Tcl_Obj *const objv[])      /* Argument objects. */
3956 {
3957     Tcl_Namespace *nsPtr;
3958
3959     if (objc == 1) {
3960         nsPtr = TclGetCurrentNamespace(interp);
3961     } else if (objc == 2) {
3962         if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
3963             return TCL_ERROR;
3964         }
3965     } else {
3966         Tcl_WrongNumArgs(interp, 1, objv, "?name?");
3967         return TCL_ERROR;
3968     }
3969
3970     /*
3971      * Report the parent of the specified namespace.
3972      */
3973
3974     if (nsPtr->parentPtr != NULL) {
3975         Tcl_SetObjResult(interp, Tcl_NewStringObj(
3976                 nsPtr->parentPtr->fullName, -1));
3977     }
3978     return TCL_OK;
3979 }
3980 \f
3981 /*
3982  *----------------------------------------------------------------------
3983  *
3984  * NamespacePathCmd --
3985  *
3986  *      Invoked to implement the "namespace path" command that reads and
3987  *      writes the current namespace's command resolution path. Has one
3988  *      optional argument: if present, it is a list of named namespaces to set
3989  *      the path to, and if absent, the current path should be returned.
3990  *      Handles the following syntax:
3991  *
3992  *          namespace path ?nsList?
3993  *
3994  * Results:
3995  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong
3996  *      (most notably if the namespace list contains the name of something
3997  *      other than a namespace). In the successful-exit case, may set the
3998  *      interpreter result to the list of names of the namespaces on the
3999  *      current namespace's path.
4000  *
4001  * Side effects:
4002  *      May update the namespace path (triggering a recomputing of all command
4003  *      names that depend on the namespace for resolution).
4004  *
4005  *----------------------------------------------------------------------
4006  */
4007
4008 static int
4009 NamespacePathCmd(
4010     ClientData dummy,           /* Not used. */
4011     Tcl_Interp *interp,         /* Current interpreter. */
4012     int objc,                   /* Number of arguments. */
4013     Tcl_Obj *const objv[])      /* Argument objects. */
4014 {
4015     Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
4016     int i, nsObjc, result = TCL_ERROR;
4017     Tcl_Obj **nsObjv;
4018     Tcl_Namespace **namespaceList = NULL;
4019
4020     if (objc > 2) {
4021         Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
4022         return TCL_ERROR;
4023     }
4024
4025     /*
4026      * If no path is given, return the current path.
4027      */
4028
4029     if (objc == 1) {
4030         Tcl_Obj *resultObj;
4031
4032         TclNewObj(resultObj);
4033         for (i=0 ; i<nsPtr->commandPathLength ; i++) {
4034             if (nsPtr->commandPathArray[i].nsPtr != NULL) {
4035                 Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
4036                         nsPtr->commandPathArray[i].nsPtr->fullName, -1));
4037             }
4038         }
4039         Tcl_SetObjResult(interp, resultObj);
4040         return TCL_OK;
4041     }
4042
4043     /*
4044      * There is a path given, so parse it into an array of namespace pointers.
4045      */
4046
4047     if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
4048         goto badNamespace;
4049     }
4050     if (nsObjc != 0) {
4051         namespaceList = TclStackAlloc(interp,
4052                 sizeof(Tcl_Namespace *) * nsObjc);
4053
4054         for (i=0 ; i<nsObjc ; i++) {
4055             if (TclGetNamespaceFromObj(interp, nsObjv[i],
4056                     &namespaceList[i]) != TCL_OK) {
4057                 goto badNamespace;
4058             }
4059         }
4060     }
4061
4062     /*
4063      * Now we have the list of valid namespaces, install it as the path.
4064      */
4065
4066     TclSetNsPath(nsPtr, nsObjc, namespaceList);
4067
4068     result = TCL_OK;
4069   badNamespace:
4070     if (namespaceList != NULL) {
4071         TclStackFree(interp, namespaceList);
4072     }
4073     return result;
4074 }
4075 \f
4076 /*
4077  *----------------------------------------------------------------------
4078  *
4079  * TclSetNsPath --
4080  *
4081  *      Sets the namespace command name resolution path to the given list of
4082  *      namespaces. If the list is empty (of zero length) the path is set to
4083  *      empty and the default old-style behaviour of command name resolution
4084  *      is used.
4085  *
4086  * Results:
4087  *      nothing
4088  *
4089  * Side effects:
4090  *      Invalidates the command name resolution caches for any command
4091  *      resolved in the given namespace.
4092  *
4093  *----------------------------------------------------------------------
4094  */
4095
4096 void
4097 TclSetNsPath(
4098     Namespace *nsPtr,           /* Namespace whose path is to be set. */
4099     int pathLength,             /* Length of pathAry. */
4100     Tcl_Namespace *pathAry[])   /* Array of namespaces that are the path. */
4101 {
4102     if (pathLength != 0) {
4103         NamespacePathEntry *tmpPathArray =
4104                 ckalloc(sizeof(NamespacePathEntry) * pathLength);
4105         int i;
4106
4107         for (i=0 ; i<pathLength ; i++) {
4108             tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
4109             tmpPathArray[i].creatorNsPtr = nsPtr;
4110             tmpPathArray[i].prevPtr = NULL;
4111             tmpPathArray[i].nextPtr =
4112                     tmpPathArray[i].nsPtr->commandPathSourceList;
4113             if (tmpPathArray[i].nextPtr != NULL) {
4114                 tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i];
4115             }
4116             tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i];
4117         }
4118         if (nsPtr->commandPathLength != 0) {
4119             UnlinkNsPath(nsPtr);
4120         }
4121         nsPtr->commandPathArray = tmpPathArray;
4122     } else {
4123         if (nsPtr->commandPathLength != 0) {
4124             UnlinkNsPath(nsPtr);
4125         }
4126     }
4127
4128     nsPtr->commandPathLength = pathLength;
4129     nsPtr->cmdRefEpoch++;
4130     nsPtr->resolverEpoch++;
4131 }
4132 \f
4133 /*
4134  *----------------------------------------------------------------------
4135  *
4136  * UnlinkNsPath --
4137  *
4138  *      Delete the given namespace's command name resolution path. Only call
4139  *      if the path is non-empty. Caller must reset the counter containing the
4140  *      path size.
4141  *
4142  * Results:
4143  *      nothing
4144  *
4145  * Side effects:
4146  *      Deletes the array of path entries and unlinks those path entries from
4147  *      the target namespace's list of interested namespaces.
4148  *
4149  *----------------------------------------------------------------------
4150  */
4151
4152 static void
4153 UnlinkNsPath(
4154     Namespace *nsPtr)
4155 {
4156     int i;
4157     for (i=0 ; i<nsPtr->commandPathLength ; i++) {
4158         NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
4159
4160         if (nsPathPtr->prevPtr != NULL) {
4161             nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
4162         }
4163         if (nsPathPtr->nextPtr != NULL) {
4164             nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
4165         }
4166         if (nsPathPtr->nsPtr != NULL) {
4167             if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
4168                 nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
4169             }
4170         }
4171     }
4172     ckfree(nsPtr->commandPathArray);
4173 }
4174 \f
4175 /*
4176  *----------------------------------------------------------------------
4177  *
4178  * TclInvalidateNsPath --
4179  *
4180  *      Invalidate the name resolution caches for all names looked up in
4181  *      namespaces whose name path includes the given namespace.
4182  *
4183  * Results:
4184  *      nothing
4185  *
4186  * Side effects:
4187  *      Increments the command reference epoch in each namespace whose path
4188  *      includes the given namespace. This causes any cached resolved names
4189  *      whose root cacheing context starts at that namespace to be recomputed
4190  *      the next time they are used.
4191  *
4192  *----------------------------------------------------------------------
4193  */
4194
4195 void
4196 TclInvalidateNsPath(
4197     Namespace *nsPtr)
4198 {
4199     NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
4200
4201     while (nsPathPtr != NULL) {
4202         if (nsPathPtr->nsPtr != NULL) {
4203             nsPathPtr->creatorNsPtr->cmdRefEpoch++;
4204         }
4205         nsPathPtr = nsPathPtr->nextPtr;
4206     }
4207 }
4208 \f
4209 /*
4210  *----------------------------------------------------------------------
4211  *
4212  * NamespaceQualifiersCmd --
4213  *
4214  *      Invoked to implement the "namespace qualifiers" command that returns
4215  *      any leading namespace qualifiers in a string. These qualifiers are
4216  *      namespace names separated by "::"s. For example, for "::foo::p" this
4217  *      command returns "::foo", and for "::" it returns "". This command is
4218  *      the complement of the "namespace tail" command. Note that this command
4219  *      does not check whether the "namespace" names are, in fact, the names
4220  *      of currently defined namespaces. Handles the following syntax:
4221  *
4222  *          namespace qualifiers string
4223  *
4224  * Results:
4225  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4226  *
4227  * Side effects:
4228  *      Returns a result in the interpreter's result object. If anything goes
4229  *      wrong, the result is an error message.
4230  *
4231  *----------------------------------------------------------------------
4232  */
4233
4234 static int
4235 NamespaceQualifiersCmd(
4236     ClientData dummy,           /* Not used. */
4237     Tcl_Interp *interp,         /* Current interpreter. */
4238     int objc,                   /* Number of arguments. */
4239     Tcl_Obj *const objv[])      /* Argument objects. */
4240 {
4241     const char *name, *p;
4242     int length;
4243
4244     if (objc != 2) {
4245         Tcl_WrongNumArgs(interp, 1, objv, "string");
4246         return TCL_ERROR;
4247     }
4248
4249     /*
4250      * Find the end of the string, then work backward and find the start of
4251      * the last "::" qualifier.
4252      */
4253
4254     name = TclGetString(objv[1]);
4255     for (p = name;  *p != '\0';  p++) {
4256         /* empty body */
4257     }
4258     while (--p >= name) {
4259         if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
4260             p -= 2;                     /* Back up over the :: */
4261             while ((p >= name) && (*p == ':')) {
4262                 p--;                    /* Back up over the preceeding : */
4263             }
4264             break;
4265         }
4266     }
4267
4268     if (p >= name) {
4269         length = p-name+1;
4270         Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length));
4271     }
4272     return TCL_OK;
4273 }
4274 \f
4275 /*
4276  *----------------------------------------------------------------------
4277  *
4278  * NamespaceUnknownCmd --
4279  *
4280  *      Invoked to implement the "namespace unknown" command (TIP 181) that
4281  *      sets or queries a per-namespace unknown command handler. This handler
4282  *      is called when command lookup fails (current and global ns). The
4283  *      default handler for the global namespace is ::unknown. The default
4284  *      handler for other namespaces is to call the global namespace unknown
4285  *      handler. Passing an empty list results in resetting the handler to its
4286  *      default.
4287  *
4288  *          namespace unknown ?handler?
4289  *
4290  * Results:
4291  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4292  *
4293  * Side effects:
4294  *      If no handler is specified, returns a result in the interpreter's
4295  *      result object, otherwise it sets the unknown handler pointer in the
4296  *      current namespace to the script fragment provided. If anything goes
4297  *      wrong, the result is an error message.
4298  *
4299  *----------------------------------------------------------------------
4300  */
4301
4302 static int
4303 NamespaceUnknownCmd(
4304     ClientData dummy,           /* Not used. */
4305     Tcl_Interp *interp,         /* Current interpreter. */
4306     int objc,                   /* Number of arguments. */
4307     Tcl_Obj *const objv[])      /* Argument objects. */
4308 {
4309     Tcl_Namespace *currNsPtr;
4310     Tcl_Obj *resultPtr;
4311     int rc;
4312
4313     if (objc > 2) {
4314         Tcl_WrongNumArgs(interp, 1, objv, "?script?");
4315         return TCL_ERROR;
4316     }
4317
4318     currNsPtr = TclGetCurrentNamespace(interp);
4319
4320     if (objc == 1) {
4321         /*
4322          * Introspection - return the current namespace handler.
4323          */
4324
4325         resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr);
4326         if (resultPtr == NULL) {
4327             TclNewObj(resultPtr);
4328         }
4329         Tcl_SetObjResult(interp, resultPtr);
4330     } else {
4331         rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]);
4332         if (rc == TCL_OK) {
4333             Tcl_SetObjResult(interp, objv[1]);
4334         }
4335         return rc;
4336     }
4337     return TCL_OK;
4338 }
4339 \f
4340 /*
4341  *----------------------------------------------------------------------
4342  *
4343  * Tcl_GetNamespaceUnknownHandler --
4344  *
4345  *      Returns the unknown command handler registered for the given
4346  *      namespace.
4347  *
4348  * Results:
4349  *      Returns the current unknown command handler, or NULL if none exists
4350  *      for the namespace.
4351  *
4352  * Side effects:
4353  *      None.
4354  *
4355  *----------------------------------------------------------------------
4356  */
4357
4358 Tcl_Obj *
4359 Tcl_GetNamespaceUnknownHandler(
4360     Tcl_Interp *interp,         /* The interpreter in which the namespace
4361                                  * exists. */
4362     Tcl_Namespace *nsPtr)       /* The namespace. */
4363 {
4364     Namespace *currNsPtr = (Namespace *) nsPtr;
4365
4366     if (currNsPtr->unknownHandlerPtr == NULL &&
4367             currNsPtr == ((Interp *) interp)->globalNsPtr) {
4368         /*
4369          * Default handler for global namespace is "::unknown". For all other
4370          * namespaces, it is NULL (which falls back on the global unknown
4371          * handler).
4372          */
4373
4374         TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
4375         Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
4376     }
4377     return currNsPtr->unknownHandlerPtr;
4378 }
4379 \f
4380 /*
4381  *----------------------------------------------------------------------
4382  *
4383  * Tcl_SetNamespaceUnknownHandler --
4384  *
4385  *      Sets the unknown command handler for the given namespace to the
4386  *      command prefix passed.
4387  *
4388  * Results:
4389  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4390  *
4391  * Side effects:
4392  *      Sets the namespace unknown command handler. If the passed in handler
4393  *      is NULL or an empty list, then the handler is reset to its default. If
4394  *      an error occurs, then an error message is left in the interpreter
4395  *      result.
4396  *
4397  *----------------------------------------------------------------------
4398  */
4399
4400 int
4401 Tcl_SetNamespaceUnknownHandler(
4402     Tcl_Interp *interp,         /* Interpreter in which the namespace
4403                                  * exists. */
4404     Tcl_Namespace *nsPtr,       /* Namespace which is being updated. */
4405     Tcl_Obj *handlerPtr)        /* The new handler, or NULL to reset. */
4406 {
4407     int lstlen = 0;
4408     Namespace *currNsPtr = (Namespace *) nsPtr;
4409
4410     /*
4411      * Ensure that we check for errors *first* before we change anything.
4412      */
4413
4414     if (handlerPtr != NULL) {
4415         if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
4416             /*
4417              * Not a list.
4418              */
4419
4420             return TCL_ERROR;
4421         }
4422         if (lstlen > 0) {
4423             /*
4424              * We are going to be saving this handler. Increment the reference
4425              * count before decrementing the refcount on the previous handler,
4426              * so that nothing strange can happen if we are told to set the
4427              * handler to the previous value.
4428              */
4429
4430             Tcl_IncrRefCount(handlerPtr);
4431         }
4432     }
4433
4434     /*
4435      * Remove old handler next.
4436      */
4437
4438     if (currNsPtr->unknownHandlerPtr != NULL) {
4439         Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr);
4440     }
4441
4442     /*
4443      * Install the new handler.
4444      */
4445
4446     if (lstlen > 0) {
4447         /*
4448          * Just store the handler. It already has the correct reference count.
4449          */
4450
4451         currNsPtr->unknownHandlerPtr = handlerPtr;
4452     } else {
4453         /*
4454          * If NULL or an empty list is passed, this resets to the default
4455          * handler.
4456          */
4457
4458         currNsPtr->unknownHandlerPtr = NULL;
4459     }
4460     return TCL_OK;
4461 }
4462 \f
4463 /*
4464  *----------------------------------------------------------------------
4465  *
4466  * NamespaceTailCmd --
4467  *
4468  *      Invoked to implement the "namespace tail" command that returns the
4469  *      trailing name at the end of a string with "::" namespace qualifiers.
4470  *      These qualifiers are namespace names separated by "::"s. For example,
4471  *      for "::foo::p" this command returns "p", and for "::" it returns "".
4472  *      This command is the complement of the "namespace qualifiers" command.
4473  *      Note that this command does not check whether the "namespace" names
4474  *      are, in fact, the names of currently defined namespaces. Handles the
4475  *      following syntax:
4476  *
4477  *          namespace tail string
4478  *
4479  * Results:
4480  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4481  *
4482  * Side effects:
4483  *      Returns a result in the interpreter's result object. If anything goes
4484  *      wrong, the result is an error message.
4485  *
4486  *----------------------------------------------------------------------
4487  */
4488
4489 static int
4490 NamespaceTailCmd(
4491     ClientData dummy,           /* Not used. */
4492     Tcl_Interp *interp,         /* Current interpreter. */
4493     int objc,                   /* Number of arguments. */
4494     Tcl_Obj *const objv[])      /* Argument objects. */
4495 {
4496     const char *name, *p;
4497
4498     if (objc != 2) {
4499         Tcl_WrongNumArgs(interp, 1, objv, "string");
4500         return TCL_ERROR;
4501     }
4502
4503     /*
4504      * Find the end of the string, then work backward and find the last "::"
4505      * qualifier.
4506      */
4507
4508     name = TclGetString(objv[1]);
4509     for (p = name;  *p != '\0';  p++) {
4510         /* empty body */
4511     }
4512     while (--p > name) {
4513         if ((*p == ':') && (*(p-1) == ':')) {
4514             p++;                        /* Just after the last "::" */
4515             break;
4516         }
4517     }
4518
4519     if (p >= name) {
4520         Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
4521     }
4522     return TCL_OK;
4523 }
4524 \f
4525 /*
4526  *----------------------------------------------------------------------
4527  *
4528  * NamespaceUpvarCmd --
4529  *
4530  *      Invoked to implement the "namespace upvar" command, that creates
4531  *      variables in the current scope linked to variables in another
4532  *      namespace. Handles the following syntax:
4533  *
4534  *          namespace upvar ns otherVar myVar ?otherVar myVar ...?
4535  *
4536  * Results:
4537  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4538  *
4539  * Side effects:
4540  *      Creates new variables in the current scope, linked to the
4541  *      corresponding variables in the stipulated nmamespace. If anything goes
4542  *      wrong, the result is an error message.
4543  *
4544  *----------------------------------------------------------------------
4545  */
4546
4547 static int
4548 NamespaceUpvarCmd(
4549     ClientData dummy,           /* Not used. */
4550     Tcl_Interp *interp,         /* Current interpreter. */
4551     int objc,                   /* Number of arguments. */
4552     Tcl_Obj *const objv[])      /* Argument objects. */
4553 {
4554     Interp *iPtr = (Interp *) interp;
4555     Tcl_Namespace *nsPtr, *savedNsPtr;
4556     Var *otherPtr, *arrayPtr;
4557     const char *myName;
4558
4559     if (objc < 2 || (objc & 1)) {
4560         Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?");
4561         return TCL_ERROR;
4562     }
4563
4564     if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
4565         return TCL_ERROR;
4566     }
4567
4568     objc -= 2;
4569     objv += 2;
4570
4571     for (; objc>0 ; objc-=2, objv+=2) {
4572         /*
4573          * Locate the other variable.
4574          */
4575
4576         savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
4577         iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
4578         otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
4579                 (TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG|TCL_AVOID_RESOLVERS),
4580                 "access", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
4581         iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
4582         if (otherPtr == NULL) {
4583             return TCL_ERROR;
4584         }
4585
4586         /*
4587          * Create the new variable and link it to otherPtr.
4588          */
4589
4590         myName = TclGetString(objv[1]);
4591         if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) {
4592             return TCL_ERROR;
4593         }
4594     }
4595
4596     return TCL_OK;
4597 }
4598 \f
4599 /*
4600  *----------------------------------------------------------------------
4601  *
4602  * NamespaceWhichCmd --
4603  *
4604  *      Invoked to implement the "namespace which" command that returns the
4605  *      fully-qualified name of a command or variable. If the specified
4606  *      command or variable does not exist, it returns "". Handles the
4607  *      following syntax:
4608  *
4609  *          namespace which ?-command? ?-variable? name
4610  *
4611  * Results:
4612  *      Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4613  *
4614  * Side effects:
4615  *      Returns a result in the interpreter's result object. If anything goes
4616  *      wrong, the result is an error message.
4617  *
4618  *----------------------------------------------------------------------
4619  */
4620
4621 static int
4622 NamespaceWhichCmd(
4623     ClientData dummy,           /* Not used. */
4624     Tcl_Interp *interp,         /* Current interpreter. */
4625     int objc,                   /* Number of arguments. */
4626     Tcl_Obj *const objv[])      /* Argument objects. */
4627 {
4628     static const char *const opts[] = {
4629         "-command", "-variable", NULL
4630     };
4631     int lookupType = 0;
4632     Tcl_Obj *resultPtr;
4633
4634     if (objc < 2 || objc > 3) {
4635     badArgs:
4636         Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
4637         return TCL_ERROR;
4638     } else if (objc == 3) {
4639         /*
4640          * Look for a flag controlling the lookup.
4641          */
4642
4643         if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,
4644                 &lookupType) != TCL_OK) {
4645             /*
4646              * Preserve old style of error message!
4647              */
4648
4649             Tcl_ResetResult(interp);
4650             goto badArgs;
4651         }
4652     }
4653
4654     TclNewObj(resultPtr);
4655     switch (lookupType) {
4656     case 0: {                           /* -command */
4657         Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);
4658
4659         if (cmd != NULL) {
4660             Tcl_GetCommandFullName(interp, cmd, resultPtr);
4661         }
4662         break;
4663     }
4664     case 1: {                           /* -variable */
4665         Tcl_Var var = Tcl_FindNamespaceVar(interp,
4666                 TclGetString(objv[objc-1]), NULL, /*flags*/ 0);
4667
4668         if (var != NULL) {
4669             Tcl_GetVariableFullName(interp, var, resultPtr);
4670         }
4671         break;
4672     }
4673     }
4674     Tcl_SetObjResult(interp, resultPtr);
4675     return TCL_OK;
4676 }
4677 \f
4678 /*
4679  *----------------------------------------------------------------------
4680  *
4681  * FreeNsNameInternalRep --
4682  *
4683  *      Frees the resources associated with a nsName object's internal
4684  *      representation.
4685  *
4686  * Results:
4687  *      None.
4688  *
4689  * Side effects:
4690  *      Decrements the ref count of any Namespace structure pointed to by the
4691  *      nsName's internal representation. If there are no more references to
4692  *      the namespace, it's structure will be freed.
4693  *
4694  *----------------------------------------------------------------------
4695  */
4696
4697 static void
4698 FreeNsNameInternalRep(
4699     Tcl_Obj *objPtr)    /* nsName object with internal representation
4700                                  * to free. */
4701 {
4702     ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
4703
4704     /*
4705      * Decrement the reference count of the namespace. If there are no more
4706      * references, free it up.
4707      */
4708
4709     resNamePtr->refCount--;
4710     if (resNamePtr->refCount == 0) {
4711         /*
4712          * Decrement the reference count for the cached namespace. If the
4713          * namespace is dead, and there are no more references to it, free
4714          * it.
4715          */
4716
4717         TclNsDecrRefCount(resNamePtr->nsPtr);
4718         ckfree(resNamePtr);
4719     }
4720     objPtr->typePtr = NULL;
4721 }
4722 \f
4723 /*
4724  *----------------------------------------------------------------------
4725  *
4726  * DupNsNameInternalRep --
4727  *
4728  *      Initializes the internal representation of a nsName object to a copy
4729  *      of the internal representation of another nsName object.
4730  *
4731  * Results:
4732  *      None.
4733  *
4734  * Side effects:
4735  *      copyPtr's internal rep is set to refer to the same namespace
4736  *      referenced by srcPtr's internal rep. Increments the ref count of the
4737  *      ResolvedNsName structure used to hold the namespace reference.
4738  *
4739  *----------------------------------------------------------------------
4740  */
4741
4742 static void
4743 DupNsNameInternalRep(
4744     Tcl_Obj *srcPtr,            /* Object with internal rep to copy. */
4745     Tcl_Obj *copyPtr)   /* Object with internal rep to set. */
4746 {
4747     ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1;
4748
4749     copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
4750     resNamePtr->refCount++;
4751     copyPtr->typePtr = &nsNameType;
4752 }
4753 \f
4754 /*
4755  *----------------------------------------------------------------------
4756  *
4757  * SetNsNameFromAny --
4758  *
4759  *      Attempt to generate a nsName internal representation for a Tcl object.
4760  *
4761  * Results:
4762  *      Returns TCL_OK if the value could be converted to a proper namespace
4763  *      reference. Otherwise, it returns TCL_ERROR, along with an error
4764  *      message in the interpreter's result object.
4765  *
4766  * Side effects:
4767  *      If successful, the object is made a nsName object. Its internal rep is
4768  *      set to point to a ResolvedNsName, which contains a cached pointer to
4769  *      the Namespace. Reference counts are kept on both the ResolvedNsName
4770  *      and the Namespace, so we can keep track of their usage and free them
4771  *      when appropriate.
4772  *
4773  *----------------------------------------------------------------------
4774  */
4775
4776 static int
4777 SetNsNameFromAny(
4778     Tcl_Interp *interp,         /* Points to the namespace in which to resolve
4779                                  * name. Also used for error reporting if not
4780                                  * NULL. */
4781     Tcl_Obj *objPtr)    /* The object to convert. */
4782 {
4783     const char *dummy;
4784     Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
4785     ResolvedNsName *resNamePtr;
4786     const char *name;
4787
4788     if (interp == NULL) {
4789         return TCL_ERROR;
4790     }
4791
4792     name = TclGetString(objPtr);
4793     TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
4794              &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
4795
4796     /*
4797      * If we found a namespace, then create a new ResolvedNsName structure
4798      * that holds a reference to it.
4799      */
4800
4801     if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
4802         /*
4803          * Our failed lookup proves any previously cached nsName internalrep is no
4804          * longer valid. Get rid of it so we no longer waste memory storing
4805          * it, nor time determining its invalidity again and again.
4806          */
4807
4808         if (objPtr->typePtr == &nsNameType) {
4809             TclFreeIntRep(objPtr);
4810         }
4811         return TCL_ERROR;
4812     }
4813
4814     nsPtr->refCount++;
4815     resNamePtr = ckalloc(sizeof(ResolvedNsName));
4816     resNamePtr->nsPtr = nsPtr;
4817     if ((name[0] == ':') && (name[1] == ':')) {
4818         resNamePtr->refNsPtr = NULL;
4819     } else {
4820         resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
4821     }
4822     resNamePtr->refCount = 1;
4823     TclFreeIntRep(objPtr);
4824     objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
4825     objPtr->typePtr = &nsNameType;
4826     return TCL_OK;
4827 }
4828 \f
4829 /*
4830  *----------------------------------------------------------------------
4831  *
4832  * TclGetNamespaceCommandTable --
4833  *
4834  *      Returns the hash table of commands.
4835  *
4836  * Results:
4837  *      Pointer to the hash table.
4838  *
4839  * Side effects:
4840  *      None.
4841  *
4842  *----------------------------------------------------------------------
4843  */
4844
4845 Tcl_HashTable *
4846 TclGetNamespaceCommandTable(
4847     Tcl_Namespace *nsPtr)
4848 {
4849     return &((Namespace *) nsPtr)->cmdTable;
4850 }
4851 \f
4852 /*
4853  *----------------------------------------------------------------------
4854  *
4855  * TclGetNamespaceChildTable --
4856  *
4857  *      Returns the hash table of child namespaces.
4858  *
4859  * Results:
4860  *      Pointer to the hash table.
4861  *
4862  * Side effects:
4863  *      Might allocate memory.
4864  *
4865  *----------------------------------------------------------------------
4866  */
4867
4868 Tcl_HashTable *
4869 TclGetNamespaceChildTable(
4870     Tcl_Namespace *nsPtr)
4871 {
4872     Namespace *nPtr = (Namespace *) nsPtr;
4873 #ifndef BREAK_NAMESPACE_COMPAT
4874     return &nPtr->childTable;
4875 #else
4876     if (nPtr->childTablePtr == NULL) {
4877         nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable));
4878         Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
4879     }
4880     return nPtr->childTablePtr;
4881 #endif
4882 }
4883 \f
4884 /*
4885  *----------------------------------------------------------------------
4886  *
4887  * TclLogCommandInfo --
4888  *
4889  *      This function is invoked after an error occurs in an interpreter. It
4890  *      adds information to iPtr->errorInfo/errorStack fields to describe the
4891  *      command that was being executed when the error occurred. When pc and
4892  *      tosPtr are non-NULL, conveying a bytecode execution "inner context",
4893  *      and the offending instruction is suitable, that inner context is
4894  *      recorded in errorStack.
4895  *
4896  * Results:
4897  *      None.
4898  *
4899  * Side effects:
4900  *      Information about the command is added to errorInfo/errorStack and the
4901  *      line number stored internally in the interpreter is set.
4902  *
4903  *----------------------------------------------------------------------
4904  */
4905
4906 void
4907 TclLogCommandInfo(
4908     Tcl_Interp *interp,         /* Interpreter in which to log information. */
4909     const char *script,         /* First character in script containing
4910                                  * command (must be <= command). */
4911     const char *command,        /* First character in command that generated
4912                                  * the error. */
4913     int length,                 /* Number of bytes in command (-1 means use
4914                                  * all bytes up to first null byte). */
4915     const unsigned char *pc,    /* Current pc of bytecode execution context */
4916     Tcl_Obj **tosPtr)           /* Current stack of bytecode execution
4917                                  * context */
4918 {
4919     const char *p;
4920     Interp *iPtr = (Interp *) interp;
4921     int overflow, limit = 150;
4922     Var *varPtr, *arrayPtr;
4923
4924     if (iPtr->flags & ERR_ALREADY_LOGGED) {
4925         /*
4926          * Someone else has already logged error information for this command;
4927          * we shouldn't add anything more.
4928          */
4929
4930         return;
4931     }
4932
4933     if (command != NULL) {
4934         /*
4935          * Compute the line number where the error occurred.
4936          */
4937
4938         iPtr->errorLine = 1;
4939         for (p = script; p != command; p++) {
4940             if (*p == '\n') {
4941                 iPtr->errorLine++;
4942             }
4943         }
4944
4945         if (length < 0) {
4946             length = strlen(command);
4947         }
4948         overflow = (length > limit);
4949         Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
4950                 "\n    %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
4951                 ? "while executing" : "invoked from within"),
4952                 (overflow ? limit : length), command,
4953                 (overflow ? "..." : "")));
4954
4955         varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
4956                 NULL, 0, 0, &arrayPtr);
4957         if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
4958             /*
4959              * Should not happen.
4960              */
4961
4962             return;
4963         } else {
4964             Tcl_HashEntry *hPtr
4965                     = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr);
4966             VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
4967
4968             if (tracePtr->traceProc != EstablishErrorInfoTraces) {
4969                 /*
4970                  * The most recent trace set on ::errorInfo is not the one the
4971                  * core itself puts on last. This means some other code is
4972                  * tracing the variable, and the additional trace(s) might be
4973                  * write traces that expect the timing of writes to
4974                  * ::errorInfo that existed Tcl releases before 8.5. To
4975                  * satisfy that compatibility need, we write the current
4976                  * -errorinfo value to the ::errorInfo variable.
4977                  */
4978
4979                 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
4980                         TCL_GLOBAL_ONLY);
4981             }
4982         }
4983     }
4984
4985     /*
4986      * TIP #348
4987      */
4988
4989     if (Tcl_IsShared(iPtr->errorStack)) {
4990         Tcl_Obj *newObj;
4991
4992         newObj = Tcl_DuplicateObj(iPtr->errorStack);
4993         Tcl_DecrRefCount(iPtr->errorStack);
4994         Tcl_IncrRefCount(newObj);
4995         iPtr->errorStack = newObj;
4996     }
4997     if (iPtr->resetErrorStack) {
4998         int len;
4999
5000         iPtr->resetErrorStack = 0;
5001         Tcl_ListObjLength(interp, iPtr->errorStack, &len);
5002
5003         /*
5004          * Reset while keeping the list internalrep as much as possible.
5005          */
5006
5007         Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
5008         if (pc != NULL) {
5009             Tcl_Obj *innerContext;
5010
5011             innerContext = TclGetInnerContext(interp, pc, tosPtr);
5012             if (innerContext != NULL) {
5013                 Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
5014                         iPtr->innerLiteral);
5015                 Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
5016             }
5017         } else if (command != NULL) {
5018             Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
5019                     iPtr->innerLiteral);
5020             Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
5021                     Tcl_NewStringObj(command, length));
5022         }
5023     }
5024
5025     if (!iPtr->framePtr->objc) {
5026         /*
5027          * Special frame, nothing to report.
5028          */
5029     } else if (iPtr->varFramePtr != iPtr->framePtr) {
5030         /*
5031          * uplevel case, [lappend errorstack UP $relativelevel]
5032          */
5033
5034         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
5035         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
5036                 iPtr->framePtr->level - iPtr->varFramePtr->level));
5037     } else if (iPtr->framePtr != iPtr->rootFramePtr) {
5038         /*
5039          * normal case, [lappend errorstack CALL [info level 0]]
5040          */
5041
5042         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
5043         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
5044                 iPtr->framePtr->objc, iPtr->framePtr->objv));
5045     }
5046 }
5047 \f
5048 /*
5049  *----------------------------------------------------------------------
5050  *
5051  * TclErrorStackResetIf --
5052  *
5053  *      The TIP 348 reset/no-bc part of TLCI, for specific use by
5054  *      TclCompileSyntaxError.
5055  *
5056  * Results:
5057  *      None.
5058  *
5059  * Side effects:
5060  *      Reset errorstack if it needs be, and in that case remember the
5061  *      passed-in error message as inner context.
5062  *
5063  *----------------------------------------------------------------------
5064  */
5065
5066 void
5067 TclErrorStackResetIf(
5068     Tcl_Interp *interp,
5069     const char *msg,
5070     int length)
5071 {
5072     Interp *iPtr = (Interp *) interp;
5073
5074     if (Tcl_IsShared(iPtr->errorStack)) {
5075         Tcl_Obj *newObj;
5076
5077         newObj = Tcl_DuplicateObj(iPtr->errorStack);
5078         Tcl_DecrRefCount(iPtr->errorStack);
5079         Tcl_IncrRefCount(newObj);
5080         iPtr->errorStack = newObj;
5081     }
5082     if (iPtr->resetErrorStack) {
5083         int len;
5084
5085         iPtr->resetErrorStack = 0;
5086         Tcl_ListObjLength(interp, iPtr->errorStack, &len);
5087
5088         /*
5089          * Reset while keeping the list internalrep as much as possible.
5090          */
5091
5092         Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
5093         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
5094         Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
5095                 Tcl_NewStringObj(msg, length));
5096     }
5097 }
5098 \f
5099 /*
5100  *----------------------------------------------------------------------
5101  *
5102  * Tcl_LogCommandInfo --
5103  *
5104  *      This function is invoked after an error occurs in an interpreter. It
5105  *      adds information to iPtr->errorInfo/errorStack fields to describe the
5106  *      command that was being executed when the error occurred.
5107  *
5108  * Results:
5109  *      None.
5110  *
5111  * Side effects:
5112  *      Information about the command is added to errorInfo/errorStack and the
5113  *      line number stored internally in the interpreter is set.
5114  *
5115  *----------------------------------------------------------------------
5116  */
5117
5118 void
5119 Tcl_LogCommandInfo(
5120     Tcl_Interp *interp,         /* Interpreter in which to log information. */
5121     const char *script,         /* First character in script containing
5122                                  * command (must be <= command). */
5123     const char *command,        /* First character in command that generated
5124                                  * the error. */
5125     int length)                 /* Number of bytes in command (-1 means use
5126                                  * all bytes up to first null byte). */
5127 {
5128     TclLogCommandInfo(interp, script, command, length, NULL, NULL);
5129 }
5130
5131 \f
5132 /*
5133  * Local Variables:
5134  * mode: c
5135  * c-basic-offset: 4
5136  * fill-column: 78
5137  * tab-width: 8
5138  * End:
5139  */