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. Also includes the 9 * TIP#112 ensemble machinery. 10 * 11 * Copyright (c) 1993-1997 Lucent Technologies. 12 * Copyright (c) 1997 Sun Microsystems, Inc. 13 * Copyright (c) 1998-1999 by Scriptics Corporation. 14 * Copyright (c) 2002-2005 Donal K. Fellows. 15 * Copyright (c) 2006 Neil Madden. 16 * Contributions from Don Porter, NIST, 2007. (not subject to US copyright) 17 * 18 * Originally implemented by 19 * Michael J. McLennan 20 * Bell Labs Innovations for Lucent Technologies 21 * mmclennan@lucent.com 22 * 23 * See the file "license.terms" for information on usage and redistribution of 24 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 25 * 26 * RCS: @(#) $Id: tclNamesp.c,v 1.162.2.4 2009/01/29 16:08:39 dkf Exp $ 27 */ 28 29#include "tclInt.h" 30 31/* 32 * Thread-local storage used to avoid having a global lock on data that is not 33 * limited to a single interpreter. 34 */ 35 36typedef struct ThreadSpecificData { 37 long numNsCreated; /* Count of the number of namespaces created 38 * within the thread. This value is used as a 39 * unique id for each namespace. Cannot be 40 * per-interp because the nsId is used to 41 * distinguish objects which can be passed 42 * around between interps in the same thread, 43 * but does not need to be global because 44 * object internal reps are always per-thread 45 * anyway. */ 46} ThreadSpecificData; 47 48static Tcl_ThreadDataKey dataKey; 49 50/* 51 * This structure contains a cached pointer to a namespace that is the result 52 * of resolving the namespace's name in some other namespace. It is the 53 * internal representation for a nsName object. It contains the pointer along 54 * with some information that is used to check the cached pointer's validity. 55 */ 56 57typedef struct ResolvedNsName { 58 Namespace *nsPtr; /* A cached pointer to the Namespace that the 59 * name resolved to. */ 60 Namespace *refNsPtr; /* Points to the namespace context in which the 61 * name was resolved. NULL if the name is fully 62 * qualified and thus the resolution does not 63 * depend on the context. */ 64 int refCount; /* Reference count: 1 for each nsName object 65 * that has a pointer to this ResolvedNsName 66 * structure as its internal rep. This 67 * structure can be freed when refCount 68 * becomes zero. */ 69} ResolvedNsName; 70 71/* 72 * The client data for an ensemble command. This consists of the table of 73 * commands that are actually exported by the namespace, and an epoch counter 74 * that, combined with the exportLookupEpoch field of the namespace structure, 75 * defines whether the table contains valid data or will need to be recomputed 76 * next time the ensemble command is called. 77 */ 78 79typedef struct EnsembleConfig { 80 Namespace *nsPtr; /* The namspace backing this ensemble up. */ 81 Tcl_Command token; /* The token for the command that provides 82 * ensemble support for the namespace, or NULL 83 * if the command has been deleted (or never 84 * existed; the global namespace never has an 85 * ensemble command.) */ 86 int epoch; /* The epoch at which this ensemble's table of 87 * exported commands is valid. */ 88 char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all 89 * consistent points, this will have the same 90 * number of entries as there are entries in 91 * the subcommandTable hash. */ 92 Tcl_HashTable subcommandTable; 93 /* Hash table of ensemble subcommand names, 94 * which are its keys so this also provides 95 * the storage management for those subcommand 96 * names. The contents of the entry values are 97 * object version the prefix lists to use when 98 * substituting for the command/subcommand to 99 * build the ensemble implementation command. 100 * Has to be stored here as well as in 101 * subcommandDict because that field is NULL 102 * when we are deriving the ensemble from the 103 * namespace exports list. FUTURE WORK: use 104 * object hash table here. */ 105 struct EnsembleConfig *next;/* The next ensemble in the linked list of 106 * ensembles associated with a namespace. If 107 * this field points to this ensemble, the 108 * structure has already been unlinked from 109 * all lists, and cannot be found by scanning 110 * the list from the namespace's ensemble 111 * field. */ 112 int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD 113 * and ENSEMBLE_COMPILE. */ 114 115 /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */ 116 117 Tcl_Obj *subcommandDict; /* Dictionary providing mapping from 118 * subcommands to their implementing command 119 * prefixes, or NULL if we are to build the 120 * map automatically from the namespace 121 * exports. */ 122 Tcl_Obj *subcmdList; /* List of commands that this ensemble 123 * actually provides, and whose implementation 124 * will be built using the subcommandDict (if 125 * present and defined) and by simple mapping 126 * to the namespace otherwise. If NULL, 127 * indicates that we are using the (dynamic) 128 * list of currently exported commands. */ 129 Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when 130 * no match is found (according to the rule 131 * defined by flag bit TCL_ENSEMBLE_PREFIX) or 132 * NULL to use the default error-generating 133 * behaviour. The script execution gets all 134 * the arguments to the ensemble command 135 * (including objv[0]) and will have the 136 * results passed directly back to the caller 137 * (including the error code) unless the code 138 * is TCL_CONTINUE in which case the 139 * subcommand will be reparsed by the ensemble 140 * core, presumably because the ensemble 141 * itself has been updated. */ 142} EnsembleConfig; 143 144#define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead 145 * and on its way out. */ 146 147/* 148 * Declarations for functions local to this file: 149 */ 150 151static void DeleteImportedCmd(ClientData clientData); 152static int DoImport(Tcl_Interp *interp, 153 Namespace *nsPtr, Tcl_HashEntry *hPtr, 154 const char *cmdName, const char *pattern, 155 Namespace *importNsPtr, int allowOverwrite); 156static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); 157static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, 158 const char *name1, const char *name2, int flags); 159static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, 160 const char *name1, const char *name2, int flags); 161static char * EstablishErrorCodeTraces(ClientData clientData, 162 Tcl_Interp *interp, const char *name1, 163 const char *name2, int flags); 164static char * EstablishErrorInfoTraces(ClientData clientData, 165 Tcl_Interp *interp, const char *name1, 166 const char *name2, int flags); 167static void FreeNsNameInternalRep(Tcl_Obj *objPtr); 168static int GetNamespaceFromObj(Tcl_Interp *interp, 169 Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); 170static int InvokeImportedCmd(ClientData clientData, 171 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 172static int NamespaceChildrenCmd(ClientData dummy, 173 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 174static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp, 175 int objc, Tcl_Obj *const objv[]); 176static int NamespaceCurrentCmd(ClientData dummy, 177 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 178static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp, 179 int objc, Tcl_Obj *const objv[]); 180static int NamespaceEnsembleCmd(ClientData dummy, 181 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 182static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp, 183 int objc, Tcl_Obj *const objv[]); 184static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp, 185 int objc, Tcl_Obj *const objv[]); 186static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp, 187 int objc, Tcl_Obj *const objv[]); 188static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp, 189 int objc, Tcl_Obj *const objv[]); 190static void NamespaceFree(Namespace *nsPtr); 191static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp, 192 int objc, Tcl_Obj *const objv[]); 193static int NamespaceInscopeCmd(ClientData dummy, 194 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 195static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp, 196 int objc, Tcl_Obj *const objv[]); 197static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp, 198 int objc, Tcl_Obj *const objv[]); 199static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp, 200 int objc, Tcl_Obj *const objv[]); 201static int NamespaceQualifiersCmd(ClientData dummy, 202 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 203static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp, 204 int objc, Tcl_Obj *const objv[]); 205static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp, 206 int objc, Tcl_Obj *const objv[]); 207static int NamespaceUnknownCmd(ClientData dummy, 208 Tcl_Interp *interp, int objc, 209 Tcl_Obj *const objv[]); 210static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp, 211 int objc, Tcl_Obj *const objv[]); 212static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); 213static int NsEnsembleImplementationCmd(ClientData clientData, 214 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); 215static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); 216static int NsEnsembleStringOrder(const void *strPtr1, 217 const void *strPtr2); 218static void DeleteEnsembleConfig(ClientData clientData); 219static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr, 220 EnsembleConfig *ensemblePtr, 221 const char *subcmdName, Tcl_Obj *prefixObjPtr); 222static void FreeEnsembleCmdRep(Tcl_Obj *objPtr); 223static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); 224static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr); 225static void UnlinkNsPath(Namespace *nsPtr); 226 227/* 228 * This structure defines a Tcl object type that contains a namespace 229 * reference. It is used in commands that take the name of a namespace as an 230 * argument. The namespace reference is resolved, and the result in cached in 231 * the object. 232 */ 233 234static Tcl_ObjType nsNameType = { 235 "nsName", /* the type's name */ 236 FreeNsNameInternalRep, /* freeIntRepProc */ 237 DupNsNameInternalRep, /* dupIntRepProc */ 238 NULL, /* updateStringProc */ 239 SetNsNameFromAny /* setFromAnyProc */ 240}; 241 242/* 243 * This structure defines a Tcl object type that contains a reference to an 244 * ensemble subcommand (e.g. the "length" in [string length ab]). It is used 245 * to cache the mapping between the subcommand itself and the real command 246 * that implements it. 247 */ 248 249Tcl_ObjType tclEnsembleCmdType = { 250 "ensembleCommand", /* the type's name */ 251 FreeEnsembleCmdRep, /* freeIntRepProc */ 252 DupEnsembleCmdRep, /* dupIntRepProc */ 253 StringOfEnsembleCmdRep, /* updateStringProc */ 254 NULL /* setFromAnyProc */ 255}; 256 257/* 258 *---------------------------------------------------------------------- 259 * 260 * TclInitNamespaceSubsystem -- 261 * 262 * This function is called to initialize all the structures that are used 263 * by namespaces on a per-process basis. 264 * 265 * Results: 266 * None. 267 * 268 * Side effects: 269 * None. 270 * 271 *---------------------------------------------------------------------- 272 */ 273 274void 275TclInitNamespaceSubsystem(void) 276{ 277 /* 278 * Does nothing for now. 279 */ 280} 281 282/* 283 *---------------------------------------------------------------------- 284 * 285 * Tcl_GetCurrentNamespace -- 286 * 287 * Returns a pointer to an interpreter's currently active namespace. 288 * 289 * Results: 290 * Returns a pointer to the interpreter's current namespace. 291 * 292 * Side effects: 293 * None. 294 * 295 *---------------------------------------------------------------------- 296 */ 297 298Tcl_Namespace * 299Tcl_GetCurrentNamespace( 300 register Tcl_Interp *interp)/* Interpreter whose current namespace is 301 * being queried. */ 302{ 303 return TclGetCurrentNamespace(interp); 304} 305 306/* 307 *---------------------------------------------------------------------- 308 * 309 * Tcl_GetGlobalNamespace -- 310 * 311 * Returns a pointer to an interpreter's global :: namespace. 312 * 313 * Results: 314 * Returns a pointer to the specified interpreter's global namespace. 315 * 316 * Side effects: 317 * None. 318 * 319 *---------------------------------------------------------------------- 320 */ 321 322Tcl_Namespace * 323Tcl_GetGlobalNamespace( 324 register Tcl_Interp *interp)/* Interpreter whose global namespace should 325 * be returned. */ 326{ 327 return TclGetGlobalNamespace(interp); 328} 329 330/* 331 *---------------------------------------------------------------------- 332 * 333 * Tcl_PushCallFrame -- 334 * 335 * Pushes a new call frame onto the interpreter's Tcl call stack. Called 336 * when executing a Tcl procedure or a "namespace eval" or "namespace 337 * inscope" command. 338 * 339 * Results: 340 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 341 * message in the interpreter's result object) if something goes wrong. 342 * 343 * Side effects: 344 * Modifies the interpreter's Tcl call stack. 345 * 346 *---------------------------------------------------------------------- 347 */ 348 349int 350Tcl_PushCallFrame( 351 Tcl_Interp *interp, /* Interpreter in which the new call frame is 352 * to be pushed. */ 353 Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push. 354 * Storage for this has already been allocated 355 * by the caller; typically this is the 356 * address of a CallFrame structure allocated 357 * on the caller's C stack. The call frame 358 * will be initialized by this function. The 359 * caller can pop the frame later with 360 * Tcl_PopCallFrame, and it is responsible for 361 * freeing the frame's storage. */ 362 Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame 363 * will execute. If NULL, the interpreter's 364 * current namespace will be used. */ 365 int isProcCallFrame) /* If nonzero, the frame represents a called 366 * Tcl procedure and may have local vars. Vars 367 * will ordinarily be looked up in the frame. 368 * If new variables are created, they will be 369 * created in the frame. If 0, the frame is 370 * for a "namespace eval" or "namespace 371 * inscope" command and var references are 372 * treated as references to namespace 373 * variables. */ 374{ 375 Interp *iPtr = (Interp *) interp; 376 register CallFrame *framePtr = (CallFrame *) callFramePtr; 377 register Namespace *nsPtr; 378 379 if (namespacePtr == NULL) { 380 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 381 } else { 382 nsPtr = (Namespace *) namespacePtr; 383 384 /* 385 * TODO: Examine whether it would be better to guard based on NS_DYING 386 * or NS_KILLED. It appears that these are not tested because they can 387 * be set in a global interp that has been [namespace delete]d, but 388 * which never really completely goes away because of lingering global 389 * things like ::errorInfo and [::unknown] and hidden commands. 390 * Review of those designs might permit stricter checking here. 391 */ 392 393 if (nsPtr->flags & NS_DEAD) { 394 Tcl_Panic("Trying to push call frame for dead namespace"); 395 /*NOTREACHED*/ 396 } 397 } 398 399 nsPtr->activationCount++; 400 framePtr->nsPtr = nsPtr; 401 framePtr->isProcCallFrame = isProcCallFrame; 402 framePtr->objc = 0; 403 framePtr->objv = NULL; 404 framePtr->callerPtr = iPtr->framePtr; 405 framePtr->callerVarPtr = iPtr->varFramePtr; 406 if (iPtr->varFramePtr != NULL) { 407 framePtr->level = (iPtr->varFramePtr->level + 1); 408 } else { 409 framePtr->level = 0; 410 } 411 framePtr->procPtr = NULL; /* no called procedure */ 412 framePtr->varTablePtr = NULL; /* and no local variables */ 413 framePtr->numCompiledLocals = 0; 414 framePtr->compiledLocals = NULL; 415 framePtr->clientData = NULL; 416 framePtr->localCachePtr = NULL; 417 418 /* 419 * Push the new call frame onto the interpreter's stack of procedure call 420 * frames making it the current frame. 421 */ 422 423 iPtr->framePtr = framePtr; 424 iPtr->varFramePtr = framePtr; 425 return TCL_OK; 426} 427 428/* 429 *---------------------------------------------------------------------- 430 * 431 * Tcl_PopCallFrame -- 432 * 433 * Removes a call frame from the Tcl call stack for the interpreter. 434 * Called to remove a frame previously pushed by Tcl_PushCallFrame. 435 * 436 * Results: 437 * None. 438 * 439 * Side effects: 440 * Modifies the call stack of the interpreter. Resets various fields of 441 * the popped call frame. If a namespace has been deleted and has no more 442 * activations on the call stack, the namespace is destroyed. 443 * 444 *---------------------------------------------------------------------- 445 */ 446 447void 448Tcl_PopCallFrame( 449 Tcl_Interp *interp) /* Interpreter with call frame to pop. */ 450{ 451 register Interp *iPtr = (Interp *) interp; 452 register CallFrame *framePtr = iPtr->framePtr; 453 Namespace *nsPtr; 454 455 /* 456 * It's important to remove the call frame from the interpreter's stack of 457 * call frames before deleting local variables, so that traces invoked by 458 * the variable deletion don't see the partially-deleted frame. 459 */ 460 461 if (framePtr->callerPtr) { 462 iPtr->framePtr = framePtr->callerPtr; 463 iPtr->varFramePtr = framePtr->callerVarPtr; 464 } else { 465 /* Tcl_PopCallFrame: trying to pop rootCallFrame! */ 466 } 467 468 if (framePtr->varTablePtr != NULL) { 469 TclDeleteVars(iPtr, framePtr->varTablePtr); 470 ckfree((char *) framePtr->varTablePtr); 471 framePtr->varTablePtr = NULL; 472 } 473 if (framePtr->numCompiledLocals > 0) { 474 TclDeleteCompiledLocalVars(iPtr, framePtr); 475 if (--framePtr->localCachePtr->refCount == 0) { 476 TclFreeLocalCache(interp, framePtr->localCachePtr); 477 } 478 framePtr->localCachePtr = NULL; 479 } 480 481 /* 482 * Decrement the namespace's count of active call frames. If the namespace 483 * is "dying" and there are no more active call frames, call 484 * Tcl_DeleteNamespace to destroy it. 485 */ 486 487 nsPtr = framePtr->nsPtr; 488 nsPtr->activationCount--; 489 if ((nsPtr->flags & NS_DYING) 490 && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) { 491 Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); 492 } 493 framePtr->nsPtr = NULL; 494} 495 496/* 497 *---------------------------------------------------------------------- 498 * 499 * TclPushStackFrame -- 500 * 501 * Allocates a new call frame in the interpreter's execution stack, then 502 * pushes it onto the interpreter's Tcl call stack. Called when executing 503 * a Tcl procedure or a "namespace eval" or "namespace inscope" command. 504 * 505 * Results: 506 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 507 * message in the interpreter's result object) if something goes wrong. 508 * 509 * Side effects: 510 * Modifies the interpreter's Tcl call stack. 511 * 512 *---------------------------------------------------------------------- 513 */ 514 515int 516TclPushStackFrame( 517 Tcl_Interp *interp, /* Interpreter in which the new call frame is 518 * to be pushed. */ 519 Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack 520 * allocated call frame. */ 521 Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame 522 * will execute. If NULL, the interpreter's 523 * current namespace will be used. */ 524 int isProcCallFrame) /* If nonzero, the frame represents a called 525 * Tcl procedure and may have local vars. Vars 526 * will ordinarily be looked up in the frame. 527 * If new variables are created, they will be 528 * created in the frame. If 0, the frame is 529 * for a "namespace eval" or "namespace 530 * inscope" command and var references are 531 * treated as references to namespace 532 * variables. */ 533{ 534 *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame)); 535 return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr, 536 isProcCallFrame); 537} 538 539void 540TclPopStackFrame( 541 Tcl_Interp *interp) /* Interpreter with call frame to pop. */ 542{ 543 CallFrame *freePtr = ((Interp *)interp)->framePtr; 544 545 Tcl_PopCallFrame(interp); 546 TclStackFree(interp, freePtr); 547} 548 549/* 550 *---------------------------------------------------------------------- 551 * 552 * EstablishErrorCodeTraces -- 553 * 554 * Creates traces on the ::errorCode variable to keep its value 555 * consistent with the expectations of legacy code. 556 * 557 * Results: 558 * None. 559 * 560 * Side effects: 561 * Read and unset traces are established on ::errorCode. 562 * 563 *---------------------------------------------------------------------- 564 */ 565 566static char * 567EstablishErrorCodeTraces( 568 ClientData clientData, 569 Tcl_Interp *interp, 570 const char *name1, 571 const char *name2, 572 int flags) 573{ 574 Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS, 575 ErrorCodeRead, NULL); 576 Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, 577 EstablishErrorCodeTraces, NULL); 578 return NULL; 579} 580 581/* 582 *---------------------------------------------------------------------- 583 * 584 * ErrorCodeRead -- 585 * 586 * Called when the ::errorCode variable is read. Copies the current value 587 * of the interp's errorCode field into ::errorCode. 588 * 589 * Results: 590 * None. 591 * 592 * Side effects: 593 * None. 594 * 595 *---------------------------------------------------------------------- 596 */ 597 598static char * 599ErrorCodeRead( 600 ClientData clientData, 601 Tcl_Interp *interp, 602 const char *name1, 603 const char *name2, 604 int flags) 605{ 606 Interp *iPtr = (Interp *)interp; 607 608 if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { 609 return NULL; 610 } 611 if (iPtr->errorCode) { 612 Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, 613 iPtr->errorCode, TCL_GLOBAL_ONLY); 614 return NULL; 615 } 616 if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) { 617 Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, 618 Tcl_NewObj(), TCL_GLOBAL_ONLY); 619 } 620 return NULL; 621} 622 623/* 624 *---------------------------------------------------------------------- 625 * 626 * EstablishErrorInfoTraces -- 627 * 628 * Creates traces on the ::errorInfo variable to keep its value 629 * consistent with the expectations of legacy code. 630 * 631 * Results: 632 * None. 633 * 634 * Side effects: 635 * Read and unset traces are established on ::errorInfo. 636 * 637 *---------------------------------------------------------------------- 638 */ 639 640static char * 641EstablishErrorInfoTraces( 642 ClientData clientData, 643 Tcl_Interp *interp, 644 const char *name1, 645 const char *name2, 646 int flags) 647{ 648 Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS, 649 ErrorInfoRead, NULL); 650 Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS, 651 EstablishErrorInfoTraces, NULL); 652 return NULL; 653} 654 655/* 656 *---------------------------------------------------------------------- 657 * 658 * ErrorInfoRead -- 659 * 660 * Called when the ::errorInfo variable is read. Copies the current value 661 * of the interp's errorInfo field into ::errorInfo. 662 * 663 * Results: 664 * None. 665 * 666 * Side effects: 667 * None. 668 * 669 *---------------------------------------------------------------------- 670 */ 671 672static char * 673ErrorInfoRead( 674 ClientData clientData, 675 Tcl_Interp *interp, 676 const char *name1, 677 const char *name2, 678 int flags) 679{ 680 Interp *iPtr = (Interp *) interp; 681 682 if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) { 683 return NULL; 684 } 685 if (iPtr->errorInfo) { 686 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, 687 iPtr->errorInfo, TCL_GLOBAL_ONLY); 688 return NULL; 689 } 690 if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) { 691 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, 692 Tcl_NewObj(), TCL_GLOBAL_ONLY); 693 } 694 return NULL; 695} 696 697/* 698 *---------------------------------------------------------------------- 699 * 700 * Tcl_CreateNamespace -- 701 * 702 * Creates a new namespace with the given name. If there is no active 703 * namespace (i.e., the interpreter is being initialized), the global :: 704 * namespace is created and returned. 705 * 706 * Results: 707 * Returns a pointer to the new namespace if successful. If the namespace 708 * already exists or if another error occurs, this routine returns NULL, 709 * along with an error message in the interpreter's result object. 710 * 711 * Side effects: 712 * If the name contains "::" qualifiers and a parent namespace does not 713 * already exist, it is automatically created. 714 * 715 *---------------------------------------------------------------------- 716 */ 717 718Tcl_Namespace * 719Tcl_CreateNamespace( 720 Tcl_Interp *interp, /* Interpreter in which a new namespace is 721 * being created. Also used for error 722 * reporting. */ 723 const char *name, /* Name for the new namespace. May be a 724 * qualified name with names of ancestor 725 * namespaces separated by "::"s. */ 726 ClientData clientData, /* One-word value to store with namespace. */ 727 Tcl_NamespaceDeleteProc *deleteProc) 728 /* Function called to delete client data when 729 * the namespace is deleted. NULL if no 730 * function should be called. */ 731{ 732 Interp *iPtr = (Interp *) interp; 733 register Namespace *nsPtr, *ancestorPtr; 734 Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; 735 Namespace *globalNsPtr = iPtr->globalNsPtr; 736 const char *simpleName; 737 Tcl_HashEntry *entryPtr; 738 Tcl_DString buffer1, buffer2; 739 Tcl_DString *namePtr, *buffPtr; 740 int newEntry, nameLen; 741 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 742 743 /* 744 * If there is no active namespace, the interpreter is being initialized. 745 */ 746 747 if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { 748 /* 749 * Treat this namespace as the global namespace, and avoid looking for 750 * a parent. 751 */ 752 753 parentPtr = NULL; 754 simpleName = ""; 755 } else if (*name == '\0') { 756 Tcl_ResetResult(interp); 757 Tcl_AppendResult(interp, "can't create namespace \"\": " 758 "only global namespace can have empty name", NULL); 759 return NULL; 760 } else { 761 /* 762 * Find the parent for the new namespace. 763 */ 764 765 TclGetNamespaceForQualName(interp, name, NULL, 766 /*flags*/ (TCL_CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), 767 &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); 768 769 /* 770 * If the unqualified name at the end is empty, there were trailing 771 * "::"s after the namespace's name which we ignore. The new namespace 772 * was already (recursively) created and is pointed to by parentPtr. 773 */ 774 775 if (*simpleName == '\0') { 776 return (Tcl_Namespace *) parentPtr; 777 } 778 779 /* 780 * Check for a bad namespace name and make sure that the name does not 781 * already exist in the parent namespace. 782 */ 783 784 if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { 785 Tcl_AppendResult(interp, "can't create namespace \"", name, 786 "\": already exists", NULL); 787 return NULL; 788 } 789 } 790 791 /* 792 * Create the new namespace and root it in its parent. Increment the count 793 * of namespaces created. 794 */ 795 796 nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); 797 nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1)); 798 strcpy(nsPtr->name, simpleName); 799 nsPtr->fullName = NULL; /* Set below. */ 800 nsPtr->clientData = clientData; 801 nsPtr->deleteProc = deleteProc; 802 nsPtr->parentPtr = parentPtr; 803 Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); 804 nsPtr->nsId = ++(tsdPtr->numNsCreated); 805 nsPtr->interp = interp; 806 nsPtr->flags = 0; 807 nsPtr->activationCount = 0; 808 nsPtr->refCount = 0; 809 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); 810 TclInitVarHashTable(&nsPtr->varTable, nsPtr); 811 nsPtr->exportArrayPtr = NULL; 812 nsPtr->numExportPatterns = 0; 813 nsPtr->maxExportPatterns = 0; 814 nsPtr->cmdRefEpoch = 0; 815 nsPtr->resolverEpoch = 0; 816 nsPtr->cmdResProc = NULL; 817 nsPtr->varResProc = NULL; 818 nsPtr->compiledVarResProc = NULL; 819 nsPtr->exportLookupEpoch = 0; 820 nsPtr->ensembles = NULL; 821 nsPtr->unknownHandlerPtr = NULL; 822 nsPtr->commandPathLength = 0; 823 nsPtr->commandPathArray = NULL; 824 nsPtr->commandPathSourceList = NULL; 825 826 if (parentPtr != NULL) { 827 entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, 828 &newEntry); 829 Tcl_SetHashValue(entryPtr, nsPtr); 830 } else { 831 /* 832 * In the global namespace create traces to maintain the ::errorInfo 833 * and ::errorCode variables. 834 */ 835 836 iPtr->globalNsPtr = nsPtr; 837 EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0); 838 EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0); 839 } 840 841 /* 842 * Build the fully qualified name for this namespace. 843 */ 844 845 Tcl_DStringInit(&buffer1); 846 Tcl_DStringInit(&buffer2); 847 namePtr = &buffer1; 848 buffPtr = &buffer2; 849 for (ancestorPtr = nsPtr; ancestorPtr != NULL; 850 ancestorPtr = ancestorPtr->parentPtr) { 851 if (ancestorPtr != globalNsPtr) { 852 register Tcl_DString *tempPtr = namePtr; 853 854 Tcl_DStringAppend(buffPtr, "::", 2); 855 Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1); 856 Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr), 857 Tcl_DStringLength(namePtr)); 858 859 /* 860 * Clear the unwanted buffer or we end up appending to previous 861 * results, making the namespace fullNames of nested namespaces 862 * very wrong (and strange). 863 */ 864 865 Tcl_DStringSetLength(namePtr, 0); 866 867 /* 868 * Now swap the buffer pointers so that we build in the other 869 * buffer. This is faster than repeated copying back and forth 870 * between buffers. 871 */ 872 873 namePtr = buffPtr; 874 buffPtr = tempPtr; 875 } 876 } 877 878 name = Tcl_DStringValue(namePtr); 879 nameLen = Tcl_DStringLength(namePtr); 880 nsPtr->fullName = ckalloc((unsigned) (nameLen+1)); 881 memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); 882 883 Tcl_DStringFree(&buffer1); 884 Tcl_DStringFree(&buffer2); 885 886 /* 887 * Return a pointer to the new namespace. 888 */ 889 890 return (Tcl_Namespace *) nsPtr; 891} 892 893/* 894 *---------------------------------------------------------------------- 895 * 896 * Tcl_DeleteNamespace -- 897 * 898 * Deletes a namespace and all of the commands, variables, and other 899 * namespaces within it. 900 * 901 * Results: 902 * None. 903 * 904 * Side effects: 905 * When a namespace is deleted, it is automatically removed as a child of 906 * its parent namespace. Also, all its commands, variables and child 907 * namespaces are deleted. 908 * 909 *---------------------------------------------------------------------- 910 */ 911 912void 913Tcl_DeleteNamespace( 914 Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */ 915{ 916 register Namespace *nsPtr = (Namespace *) namespacePtr; 917 Interp *iPtr = (Interp *) nsPtr->interp; 918 Namespace *globalNsPtr = (Namespace *) 919 TclGetGlobalNamespace((Tcl_Interp *) iPtr); 920 Tcl_HashEntry *entryPtr; 921 922 /* 923 * If the namespace has associated ensemble commands, delete them first. 924 * This leaves the actual contents of the namespace alone (unless they are 925 * linked ensemble commands, of course). Note that this code is actually 926 * reentrant so command delete traces won't purturb things badly. 927 */ 928 929 while (nsPtr->ensembles != NULL) { 930 EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; 931 932 /* 933 * Splice out and link to indicate that we've already been killed. 934 */ 935 936 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; 937 ensemblePtr->next = ensemblePtr; 938 Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); 939 } 940 941 /* 942 * If the namespace has a registered unknown handler (TIP 181), then free 943 * it here. 944 */ 945 946 if (nsPtr->unknownHandlerPtr != NULL) { 947 Tcl_DecrRefCount(nsPtr->unknownHandlerPtr); 948 nsPtr->unknownHandlerPtr = NULL; 949 } 950 951 /* 952 * If the namespace is on the call frame stack, it is marked as "dying" 953 * (NS_DYING is OR'd into its flags): the namespace can't be looked up by 954 * name but its commands and variables are still usable by those active 955 * call frames. When all active call frames referring to the namespace 956 * have been popped from the Tcl stack, Tcl_PopCallFrame will call this 957 * function again to delete everything in the namespace. If no nsName 958 * objects refer to the namespace (i.e., if its refCount is zero), its 959 * commands and variables are deleted and the storage for its namespace 960 * structure is freed. Otherwise, if its refCount is nonzero, the 961 * namespace's commands and variables are deleted but the structure isn't 962 * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the 963 * namespace resolution code to recognize that the namespace is "deleted". 964 * The structure's storage is freed by FreeNsNameInternalRep when its 965 * refCount reaches 0. 966 */ 967 968 if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) { 969 nsPtr->flags |= NS_DYING; 970 if (nsPtr->parentPtr != NULL) { 971 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, 972 nsPtr->name); 973 if (entryPtr != NULL) { 974 Tcl_DeleteHashEntry(entryPtr); 975 } 976 } 977 nsPtr->parentPtr = NULL; 978 } else if (!(nsPtr->flags & NS_KILLED)) { 979 /* 980 * Delete the namespace and everything in it. If this is the global 981 * namespace, then clear it but don't free its storage unless the 982 * interpreter is being torn down. Set the NS_KILLED flag to avoid 983 * recursive calls here - if the namespace is really in the process of 984 * being deleted, ignore any second call. 985 */ 986 987 nsPtr->flags |= (NS_DYING|NS_KILLED); 988 989 TclTeardownNamespace(nsPtr); 990 991 if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { 992 /* 993 * If this is the global namespace, then it may have residual 994 * "errorInfo" and "errorCode" variables for errors that occurred 995 * while it was being torn down. Try to clear the variable list 996 * one last time. 997 */ 998 999 TclDeleteNamespaceVars(nsPtr); 1000 1001 Tcl_DeleteHashTable(&nsPtr->childTable); 1002 Tcl_DeleteHashTable(&nsPtr->cmdTable); 1003 1004 /* 1005 * If the reference count is 0, then discard the namespace. 1006 * Otherwise, mark it as "dead" so that it can't be used. 1007 */ 1008 1009 if (nsPtr->refCount == 0) { 1010 NamespaceFree(nsPtr); 1011 } else { 1012 nsPtr->flags |= NS_DEAD; 1013 } 1014 } else { 1015 /* 1016 * Restore the ::errorInfo and ::errorCode traces. 1017 */ 1018 1019 EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); 1020 EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); 1021 1022 /* 1023 * We didn't really kill it, so remove the KILLED marks, so it can 1024 * get killed later, avoiding mem leaks. 1025 */ 1026 1027 nsPtr->flags &= ~(NS_DYING|NS_KILLED); 1028 } 1029 } 1030} 1031 1032/* 1033 *---------------------------------------------------------------------- 1034 * 1035 * TclTeardownNamespace -- 1036 * 1037 * Used internally to dismantle and unlink a namespace when it is 1038 * deleted. Divorces the namespace from its parent, and deletes all 1039 * commands, variables, and child namespaces. 1040 * 1041 * This is kept separate from Tcl_DeleteNamespace so that the global 1042 * namespace can be handled specially. 1043 * 1044 * Results: 1045 * None. 1046 * 1047 * Side effects: 1048 * Removes this namespace from its parent's child namespace hashtable. 1049 * Deletes all commands, variables and namespaces in this namespace. 1050 * 1051 *---------------------------------------------------------------------- 1052 */ 1053 1054void 1055TclTeardownNamespace( 1056 register Namespace *nsPtr) /* Points to the namespace to be dismantled 1057 * and unlinked from its parent. */ 1058{ 1059 Interp *iPtr = (Interp *) nsPtr->interp; 1060 register Tcl_HashEntry *entryPtr; 1061 Tcl_HashSearch search; 1062 Tcl_Namespace *childNsPtr; 1063 Tcl_Command cmd; 1064 int i; 1065 1066 /* 1067 * Start by destroying the namespace's variable table, since variables 1068 * might trigger traces. Variable table should be cleared but not freed! 1069 * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards. 1070 */ 1071 1072 TclDeleteNamespaceVars(nsPtr); 1073 TclInitVarHashTable(&nsPtr->varTable, nsPtr); 1074 1075 /* 1076 * Delete all commands in this namespace. Be careful when traversing the 1077 * hash table: when each command is deleted, it removes itself from the 1078 * command table. 1079 * 1080 * Don't optimize to Tcl_NextHashEntry() because of traces. 1081 */ 1082 1083 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 1084 entryPtr != NULL; 1085 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { 1086 cmd = Tcl_GetHashValue(entryPtr); 1087 Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); 1088 } 1089 Tcl_DeleteHashTable(&nsPtr->cmdTable); 1090 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); 1091 1092 /* 1093 * Remove the namespace from its parent's child hashtable. 1094 */ 1095 1096 if (nsPtr->parentPtr != NULL) { 1097 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, 1098 nsPtr->name); 1099 if (entryPtr != NULL) { 1100 Tcl_DeleteHashEntry(entryPtr); 1101 } 1102 } 1103 nsPtr->parentPtr = NULL; 1104 1105 /* 1106 * Delete the namespace path if one is installed. 1107 */ 1108 1109 if (nsPtr->commandPathLength != 0) { 1110 UnlinkNsPath(nsPtr); 1111 nsPtr->commandPathLength = 0; 1112 } 1113 if (nsPtr->commandPathSourceList != NULL) { 1114 NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; 1115 do { 1116 if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) { 1117 nsPathPtr->creatorNsPtr->cmdRefEpoch++; 1118 } 1119 nsPathPtr->nsPtr = NULL; 1120 nsPathPtr = nsPathPtr->nextPtr; 1121 } while (nsPathPtr != NULL); 1122 nsPtr->commandPathSourceList = NULL; 1123 } 1124 1125 /* 1126 * Delete all the child namespaces. 1127 * 1128 * BE CAREFUL: When each child is deleted, it will divorce itself from its 1129 * parent. You can't traverse a hash table properly if its elements are 1130 * being deleted. We use only the Tcl_FirstHashEntry function to be safe. 1131 * 1132 * Don't optimize to Tcl_NextHashEntry() because of traces. 1133 */ 1134 1135 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); 1136 entryPtr != NULL; 1137 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { 1138 childNsPtr = Tcl_GetHashValue(entryPtr); 1139 Tcl_DeleteNamespace(childNsPtr); 1140 } 1141 1142 /* 1143 * Free the namespace's export pattern array. 1144 */ 1145 1146 if (nsPtr->exportArrayPtr != NULL) { 1147 for (i = 0; i < nsPtr->numExportPatterns; i++) { 1148 ckfree(nsPtr->exportArrayPtr[i]); 1149 } 1150 ckfree((char *) nsPtr->exportArrayPtr); 1151 nsPtr->exportArrayPtr = NULL; 1152 nsPtr->numExportPatterns = 0; 1153 nsPtr->maxExportPatterns = 0; 1154 } 1155 1156 /* 1157 * Free any client data associated with the namespace. 1158 */ 1159 1160 if (nsPtr->deleteProc != NULL) { 1161 (*nsPtr->deleteProc)(nsPtr->clientData); 1162 } 1163 nsPtr->deleteProc = NULL; 1164 nsPtr->clientData = NULL; 1165 1166 /* 1167 * Reset the namespace's id field to ensure that this namespace won't be 1168 * interpreted as valid by, e.g., the cache validation code for cached 1169 * command references in Tcl_GetCommandFromObj. 1170 */ 1171 1172 nsPtr->nsId = 0; 1173} 1174 1175/* 1176 *---------------------------------------------------------------------- 1177 * 1178 * NamespaceFree -- 1179 * 1180 * Called after a namespace has been deleted, when its reference count 1181 * reaches 0. Frees the data structure representing the namespace. 1182 * 1183 * Results: 1184 * None. 1185 * 1186 * Side effects: 1187 * None. 1188 * 1189 *---------------------------------------------------------------------- 1190 */ 1191 1192static void 1193NamespaceFree( 1194 register Namespace *nsPtr) /* Points to the namespace to free. */ 1195{ 1196 /* 1197 * Most of the namespace's contents are freed when the namespace is 1198 * deleted by Tcl_DeleteNamespace. All that remains is to free its names 1199 * (for error messages), and the structure itself. 1200 */ 1201 1202 ckfree(nsPtr->name); 1203 ckfree(nsPtr->fullName); 1204 1205 ckfree((char *) nsPtr); 1206} 1207 1208/* 1209 *---------------------------------------------------------------------- 1210 * 1211 * Tcl_Export -- 1212 * 1213 * Makes all the commands matching a pattern available to later be 1214 * imported from the namespace specified by namespacePtr (or the current 1215 * namespace if namespacePtr is NULL). The specified pattern is appended 1216 * onto the namespace's export pattern list, which is optionally cleared 1217 * beforehand. 1218 * 1219 * Results: 1220 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 1221 * message in the interpreter's result) if something goes wrong. 1222 * 1223 * Side effects: 1224 * Appends the export pattern onto the namespace's export list. 1225 * Optionally reset the namespace's export pattern list. 1226 * 1227 *---------------------------------------------------------------------- 1228 */ 1229 1230int 1231Tcl_Export( 1232 Tcl_Interp *interp, /* Current interpreter. */ 1233 Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands 1234 * are to be exported. NULL for the current 1235 * namespace. */ 1236 const char *pattern, /* String pattern indicating which commands to 1237 * export. This pattern may not include any 1238 * namespace qualifiers; only commands in the 1239 * specified namespace may be exported. */ 1240 int resetListFirst) /* If nonzero, resets the namespace's export 1241 * list before appending. */ 1242{ 1243#define INIT_EXPORT_PATTERNS 5 1244 Namespace *nsPtr, *exportNsPtr, *dummyPtr; 1245 Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); 1246 const char *simplePattern; 1247 char *patternCpy; 1248 int neededElems, len, i; 1249 1250 /* 1251 * If the specified namespace is NULL, use the current namespace. 1252 */ 1253 1254 if (namespacePtr == NULL) { 1255 nsPtr = (Namespace *) currNsPtr; 1256 } else { 1257 nsPtr = (Namespace *) namespacePtr; 1258 } 1259 1260 /* 1261 * If resetListFirst is true (nonzero), clear the namespace's export 1262 * pattern list. 1263 */ 1264 1265 if (resetListFirst) { 1266 if (nsPtr->exportArrayPtr != NULL) { 1267 for (i = 0; i < nsPtr->numExportPatterns; i++) { 1268 ckfree(nsPtr->exportArrayPtr[i]); 1269 } 1270 ckfree((char *) nsPtr->exportArrayPtr); 1271 nsPtr->exportArrayPtr = NULL; 1272 TclInvalidateNsCmdLookup(nsPtr); 1273 nsPtr->numExportPatterns = 0; 1274 nsPtr->maxExportPatterns = 0; 1275 } 1276 } 1277 1278 /* 1279 * Check that the pattern doesn't have namespace qualifiers. 1280 */ 1281 1282 TclGetNamespaceForQualName(interp, pattern, nsPtr, 1283 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 1284 &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 1285 1286 if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { 1287 Tcl_AppendResult(interp, "invalid export pattern \"", pattern, 1288 "\": pattern can't specify a namespace", NULL); 1289 return TCL_ERROR; 1290 } 1291 1292 /* 1293 * Make sure that we don't already have the pattern in the array 1294 */ 1295 1296 if (nsPtr->exportArrayPtr != NULL) { 1297 for (i = 0; i < nsPtr->numExportPatterns; i++) { 1298 if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { 1299 /* 1300 * The pattern already exists in the list. 1301 */ 1302 1303 return TCL_OK; 1304 } 1305 } 1306 } 1307 1308 /* 1309 * Make sure there is room in the namespace's pattern array for the new 1310 * pattern. 1311 */ 1312 1313 neededElems = nsPtr->numExportPatterns + 1; 1314 if (neededElems > nsPtr->maxExportPatterns) { 1315 nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 1316 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; 1317 nsPtr->exportArrayPtr = (char **) 1318 ckrealloc((char *) nsPtr->exportArrayPtr, 1319 sizeof(char *) * nsPtr->maxExportPatterns); 1320 } 1321 1322 /* 1323 * Add the pattern to the namespace's array of export patterns. 1324 */ 1325 1326 len = strlen(pattern); 1327 patternCpy = ckalloc((unsigned) (len + 1)); 1328 memcpy(patternCpy, pattern, (unsigned) len + 1); 1329 1330 nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; 1331 nsPtr->numExportPatterns++; 1332 1333 /* 1334 * The list of commands actually exported from the namespace might have 1335 * changed (probably will have!) However, we do not need to recompute this 1336 * just yet; next time we need the info will be soon enough. 1337 */ 1338 1339 TclInvalidateNsCmdLookup(nsPtr); 1340 1341 return TCL_OK; 1342#undef INIT_EXPORT_PATTERNS 1343} 1344 1345/* 1346 *---------------------------------------------------------------------- 1347 * 1348 * Tcl_AppendExportList -- 1349 * 1350 * Appends onto the argument object the list of export patterns for the 1351 * specified namespace. 1352 * 1353 * Results: 1354 * The return value is normally TCL_OK; in this case the object 1355 * referenced by objPtr has each export pattern appended to it. If an 1356 * error occurs, TCL_ERROR is returned and the interpreter's result holds 1357 * an error message. 1358 * 1359 * Side effects: 1360 * If necessary, the object referenced by objPtr is converted into a list 1361 * object. 1362 * 1363 *---------------------------------------------------------------------- 1364 */ 1365 1366int 1367Tcl_AppendExportList( 1368 Tcl_Interp *interp, /* Interpreter used for error reporting. */ 1369 Tcl_Namespace *namespacePtr,/* Points to the namespace whose export 1370 * pattern list is appended onto objPtr. NULL 1371 * for the current namespace. */ 1372 Tcl_Obj *objPtr) /* Points to the Tcl object onto which the 1373 * export pattern list is appended. */ 1374{ 1375 Namespace *nsPtr; 1376 int i, result; 1377 1378 /* 1379 * If the specified namespace is NULL, use the current namespace. 1380 */ 1381 1382 if (namespacePtr == NULL) { 1383 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 1384 } else { 1385 nsPtr = (Namespace *) namespacePtr; 1386 } 1387 1388 /* 1389 * Append the export pattern list onto objPtr. 1390 */ 1391 1392 for (i = 0; i < nsPtr->numExportPatterns; i++) { 1393 result = Tcl_ListObjAppendElement(interp, objPtr, 1394 Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); 1395 if (result != TCL_OK) { 1396 return result; 1397 } 1398 } 1399 return TCL_OK; 1400} 1401 1402/* 1403 *---------------------------------------------------------------------- 1404 * 1405 * Tcl_Import -- 1406 * 1407 * Imports all of the commands matching a pattern into the namespace 1408 * specified by namespacePtr (or the current namespace if contextNsPtr is 1409 * NULL). This is done by creating a new command (the "imported command") 1410 * that points to the real command in its original namespace. 1411 * 1412 * If matching commands are on the autoload path but haven't been loaded 1413 * yet, this command forces them to be loaded, then creates the links to 1414 * them. 1415 * 1416 * Results: 1417 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 1418 * message in the interpreter's result) if something goes wrong. 1419 * 1420 * Side effects: 1421 * Creates new commands in the importing namespace. These indirect calls 1422 * back to the real command and are deleted if the real commands are 1423 * deleted. 1424 * 1425 *---------------------------------------------------------------------- 1426 */ 1427 1428int 1429Tcl_Import( 1430 Tcl_Interp *interp, /* Current interpreter. */ 1431 Tcl_Namespace *namespacePtr,/* Points to the namespace into which the 1432 * commands are to be imported. NULL for the 1433 * current namespace. */ 1434 const char *pattern, /* String pattern indicating which commands to 1435 * import. This pattern should be qualified by 1436 * the name of the namespace from which to 1437 * import the command(s). */ 1438 int allowOverwrite) /* If nonzero, allow existing commands to be 1439 * overwritten by imported commands. If 0, 1440 * return an error if an imported cmd 1441 * conflicts with an existing one. */ 1442{ 1443 Namespace *nsPtr, *importNsPtr, *dummyPtr; 1444 const char *simplePattern; 1445 register Tcl_HashEntry *hPtr; 1446 Tcl_HashSearch search; 1447 1448 /* 1449 * If the specified namespace is NULL, use the current namespace. 1450 */ 1451 1452 if (namespacePtr == NULL) { 1453 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 1454 } else { 1455 nsPtr = (Namespace *) namespacePtr; 1456 } 1457 1458 /* 1459 * First, invoke the "auto_import" command with the pattern being 1460 * imported. This command is part of the Tcl library. It looks for 1461 * imported commands in autoloaded libraries and loads them in. That way, 1462 * they will be found when we try to create links below. 1463 * 1464 * Note that we don't just call Tcl_EvalObjv() directly because we do not 1465 * want absence of the command to be a failure case. 1466 */ 1467 1468 if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) { 1469 Tcl_Obj *objv[2]; 1470 int result; 1471 1472 TclNewLiteralStringObj(objv[0], "auto_import"); 1473 objv[1] = Tcl_NewStringObj(pattern, -1); 1474 1475 Tcl_IncrRefCount(objv[0]); 1476 Tcl_IncrRefCount(objv[1]); 1477 result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY); 1478 Tcl_DecrRefCount(objv[0]); 1479 Tcl_DecrRefCount(objv[1]); 1480 1481 if (result != TCL_OK) { 1482 return TCL_ERROR; 1483 } 1484 Tcl_ResetResult(interp); 1485 } 1486 1487 /* 1488 * From the pattern, find the namespace from which we are importing and 1489 * get the simple pattern (no namespace qualifiers or ::'s) at the end. 1490 */ 1491 1492 if (strlen(pattern) == 0) { 1493 Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1)); 1494 return TCL_ERROR; 1495 } 1496 TclGetNamespaceForQualName(interp, pattern, nsPtr, 1497 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 1498 &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 1499 1500 if (importNsPtr == NULL) { 1501 Tcl_AppendResult(interp, "unknown namespace in import pattern \"", 1502 pattern, "\"", NULL); 1503 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); 1504 return TCL_ERROR; 1505 } 1506 if (importNsPtr == nsPtr) { 1507 if (pattern == simplePattern) { 1508 Tcl_AppendResult(interp, 1509 "no namespace specified in import pattern \"", pattern, 1510 "\"", NULL); 1511 } else { 1512 Tcl_AppendResult(interp, "import pattern \"", pattern, 1513 "\" tries to import from namespace \"", 1514 importNsPtr->name, "\" into itself", NULL); 1515 } 1516 return TCL_ERROR; 1517 } 1518 1519 /* 1520 * Scan through the command table in the source namespace and look for 1521 * exported commands that match the string pattern. Create an "imported 1522 * command" in the current namespace for each imported command; these 1523 * commands redirect their invocations to the "real" command. 1524 */ 1525 1526 if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) { 1527 hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern); 1528 if (hPtr == NULL) { 1529 return TCL_OK; 1530 } 1531 return DoImport(interp, nsPtr, hPtr, simplePattern, pattern, 1532 importNsPtr, allowOverwrite); 1533 } 1534 for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); 1535 (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { 1536 char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); 1537 if (Tcl_StringMatch(cmdName, simplePattern) && 1538 DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, 1539 allowOverwrite) == TCL_ERROR) { 1540 return TCL_ERROR; 1541 } 1542 } 1543 return TCL_OK; 1544} 1545 1546/* 1547 *---------------------------------------------------------------------- 1548 * 1549 * DoImport -- 1550 * 1551 * Import a particular command from one namespace into another. Helper 1552 * for Tcl_Import(). 1553 * 1554 * Results: 1555 * Standard Tcl result code. If TCL_ERROR, appends an error message to 1556 * the interpreter result. 1557 * 1558 * Side effects: 1559 * A new command is created in the target namespace unless this is a 1560 * reimport of exactly the same command as before. 1561 * 1562 *---------------------------------------------------------------------- 1563 */ 1564 1565static int 1566DoImport( 1567 Tcl_Interp *interp, 1568 Namespace *nsPtr, 1569 Tcl_HashEntry *hPtr, 1570 const char *cmdName, 1571 const char *pattern, 1572 Namespace *importNsPtr, 1573 int allowOverwrite) 1574{ 1575 int i = 0, exported = 0; 1576 Tcl_HashEntry *found; 1577 1578 /* 1579 * The command cmdName in the source namespace matches the pattern. Check 1580 * whether it was exported. If it wasn't, we ignore it. 1581 */ 1582 1583 while (!exported && (i < importNsPtr->numExportPatterns)) { 1584 exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]); 1585 } 1586 if (!exported) { 1587 return TCL_OK; 1588 } 1589 1590 /* 1591 * Unless there is a name clash, create an imported command in the current 1592 * namespace that refers to cmdPtr. 1593 */ 1594 1595 found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); 1596 if ((found == NULL) || allowOverwrite) { 1597 /* 1598 * Create the imported command and its client data. To create the new 1599 * command in the current namespace, generate a fully qualified name 1600 * for it. 1601 */ 1602 1603 Tcl_DString ds; 1604 Tcl_Command importedCmd; 1605 ImportedCmdData *dataPtr; 1606 Command *cmdPtr; 1607 ImportRef *refPtr; 1608 1609 Tcl_DStringInit(&ds); 1610 Tcl_DStringAppend(&ds, nsPtr->fullName, -1); 1611 if (nsPtr != ((Interp *) interp)->globalNsPtr) { 1612 Tcl_DStringAppend(&ds, "::", 2); 1613 } 1614 Tcl_DStringAppend(&ds, cmdName, -1); 1615 1616 /* 1617 * Check whether creating the new imported command in the current 1618 * namespace would create a cycle of imported command references. 1619 */ 1620 1621 cmdPtr = Tcl_GetHashValue(hPtr); 1622 if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) { 1623 Command *overwrite = Tcl_GetHashValue(found); 1624 Command *link = cmdPtr; 1625 1626 while (link->deleteProc == DeleteImportedCmd) { 1627 ImportedCmdData *dataPtr = link->objClientData; 1628 1629 link = dataPtr->realCmdPtr; 1630 if (overwrite == link) { 1631 Tcl_AppendResult(interp, "import pattern \"", pattern, 1632 "\" would create a loop containing command \"", 1633 Tcl_DStringValue(&ds), "\"", NULL); 1634 Tcl_DStringFree(&ds); 1635 return TCL_ERROR; 1636 } 1637 } 1638 } 1639 1640 dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); 1641 importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), 1642 InvokeImportedCmd, dataPtr, DeleteImportedCmd); 1643 dataPtr->realCmdPtr = cmdPtr; 1644 dataPtr->selfPtr = (Command *) importedCmd; 1645 dataPtr->selfPtr->compileProc = cmdPtr->compileProc; 1646 Tcl_DStringFree(&ds); 1647 1648 /* 1649 * Create an ImportRef structure describing this new import command 1650 * and add it to the import ref list in the "real" command. 1651 */ 1652 1653 refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); 1654 refPtr->importedCmdPtr = (Command *) importedCmd; 1655 refPtr->nextPtr = cmdPtr->importRefPtr; 1656 cmdPtr->importRefPtr = refPtr; 1657 } else { 1658 Command *overwrite = Tcl_GetHashValue(found); 1659 1660 if (overwrite->deleteProc == DeleteImportedCmd) { 1661 ImportedCmdData *dataPtr = overwrite->objClientData; 1662 1663 if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) { 1664 /* 1665 * Repeated import of same command is acceptable. 1666 */ 1667 1668 return TCL_OK; 1669 } 1670 } 1671 Tcl_AppendResult(interp, "can't import command \"", cmdName, 1672 "\": already exists", NULL); 1673 return TCL_ERROR; 1674 } 1675 return TCL_OK; 1676} 1677 1678/* 1679 *---------------------------------------------------------------------- 1680 * 1681 * Tcl_ForgetImport -- 1682 * 1683 * Deletes commands previously imported into the namespace indicated. 1684 * The by namespacePtr, or the current namespace of interp, when 1685 * namespacePtr is NULL. The pattern controls which imported commands are 1686 * deleted. A simple pattern, one without namespace separators, matches 1687 * the current command names of imported commands in the namespace. 1688 * Matching imported commands are deleted. A qualified pattern is 1689 * interpreted as deletion selection on the basis of where the command is 1690 * imported from. The original command and "first link" command for each 1691 * imported command are determined, and they are matched against the 1692 * pattern. A match leads to deletion of the imported command. 1693 * 1694 * Results: 1695 * Returns TCL_ERROR and records an error message in the interp result if 1696 * a namespace qualified pattern refers to a namespace that does not 1697 * exist. Otherwise, returns TCL_OK. 1698 * 1699 * Side effects: 1700 * May delete commands. 1701 * 1702 *---------------------------------------------------------------------- 1703 */ 1704 1705int 1706Tcl_ForgetImport( 1707 Tcl_Interp *interp, /* Current interpreter. */ 1708 Tcl_Namespace *namespacePtr,/* Points to the namespace from which 1709 * previously imported commands should be 1710 * removed. NULL for current namespace. */ 1711 const char *pattern) /* String pattern indicating which imported 1712 * commands to remove. */ 1713{ 1714 Namespace *nsPtr, *sourceNsPtr, *dummyPtr; 1715 const char *simplePattern; 1716 char *cmdName; 1717 register Tcl_HashEntry *hPtr; 1718 Tcl_HashSearch search; 1719 1720 /* 1721 * If the specified namespace is NULL, use the current namespace. 1722 */ 1723 1724 if (namespacePtr == NULL) { 1725 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 1726 } else { 1727 nsPtr = (Namespace *) namespacePtr; 1728 } 1729 1730 /* 1731 * Parse the pattern into its namespace-qualification (if any) and the 1732 * simple pattern. 1733 */ 1734 1735 TclGetNamespaceForQualName(interp, pattern, nsPtr, 1736 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 1737 &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 1738 1739 if (sourceNsPtr == NULL) { 1740 Tcl_AppendResult(interp, 1741 "unknown namespace in namespace forget pattern \"", 1742 pattern, "\"", NULL); 1743 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL); 1744 return TCL_ERROR; 1745 } 1746 1747 if (strcmp(pattern, simplePattern) == 0) { 1748 /* 1749 * The pattern is simple. Delete any imported commands that match it. 1750 */ 1751 1752 if (TclMatchIsTrivial(simplePattern)) { 1753 Command *cmdPtr; 1754 1755 hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); 1756 if ((hPtr != NULL) 1757 && (cmdPtr = Tcl_GetHashValue(hPtr)) 1758 && (cmdPtr->deleteProc == DeleteImportedCmd)) { 1759 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 1760 } 1761 return TCL_OK; 1762 } 1763 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 1764 (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) { 1765 Command *cmdPtr = Tcl_GetHashValue(hPtr); 1766 1767 if (cmdPtr->deleteProc != DeleteImportedCmd) { 1768 continue; 1769 } 1770 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); 1771 if (Tcl_StringMatch(cmdName, simplePattern)) { 1772 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 1773 } 1774 } 1775 return TCL_OK; 1776 } 1777 1778 /* 1779 * The pattern was namespace-qualified. 1780 */ 1781 1782 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); 1783 hPtr = Tcl_NextHashEntry(&search)) { 1784 Tcl_CmdInfo info; 1785 Tcl_Command token = Tcl_GetHashValue(hPtr); 1786 Tcl_Command origin = TclGetOriginalCommand(token); 1787 1788 if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { 1789 continue; /* Not an imported command. */ 1790 } 1791 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { 1792 /* 1793 * Original not in namespace we're matching. Check the first link 1794 * in the import chain. 1795 */ 1796 1797 Command *cmdPtr = (Command *) token; 1798 ImportedCmdData *dataPtr = cmdPtr->objClientData; 1799 Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; 1800 1801 if (firstToken == origin) { 1802 continue; 1803 } 1804 Tcl_GetCommandInfoFromToken(firstToken, &info); 1805 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { 1806 continue; 1807 } 1808 origin = firstToken; 1809 } 1810 if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { 1811 Tcl_DeleteCommandFromToken(interp, token); 1812 } 1813 } 1814 return TCL_OK; 1815} 1816 1817/* 1818 *---------------------------------------------------------------------- 1819 * 1820 * TclGetOriginalCommand -- 1821 * 1822 * An imported command is created in an namespace when a "real" command 1823 * is imported from another namespace. If the specified command is an 1824 * imported command, this function returns the original command it refers 1825 * to. 1826 * 1827 * Results: 1828 * If the command was imported into a sequence of namespaces a, b,...,n 1829 * where each successive namespace just imports the command from the 1830 * previous namespace, this function returns the Tcl_Command token in the 1831 * first namespace, a. Otherwise, if the specified command is not an 1832 * imported command, the function returns NULL. 1833 * 1834 * Side effects: 1835 * None. 1836 * 1837 *---------------------------------------------------------------------- 1838 */ 1839 1840Tcl_Command 1841TclGetOriginalCommand( 1842 Tcl_Command command) /* The imported command for which the original 1843 * command should be returned. */ 1844{ 1845 register Command *cmdPtr = (Command *) command; 1846 ImportedCmdData *dataPtr; 1847 1848 if (cmdPtr->deleteProc != DeleteImportedCmd) { 1849 return NULL; 1850 } 1851 1852 while (cmdPtr->deleteProc == DeleteImportedCmd) { 1853 dataPtr = cmdPtr->objClientData; 1854 cmdPtr = dataPtr->realCmdPtr; 1855 } 1856 return (Tcl_Command) cmdPtr; 1857} 1858 1859/* 1860 *---------------------------------------------------------------------- 1861 * 1862 * InvokeImportedCmd -- 1863 * 1864 * Invoked by Tcl whenever the user calls an imported command that was 1865 * created by Tcl_Import. Finds the "real" command (in another 1866 * namespace), and passes control to it. 1867 * 1868 * Results: 1869 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 1870 * 1871 * Side effects: 1872 * Returns a result in the interpreter's result object. If anything goes 1873 * wrong, the result object is set to an error message. 1874 * 1875 *---------------------------------------------------------------------- 1876 */ 1877 1878static int 1879InvokeImportedCmd( 1880 ClientData clientData, /* Points to the imported command's 1881 * ImportedCmdData structure. */ 1882 Tcl_Interp *interp, /* Current interpreter. */ 1883 int objc, /* Number of arguments. */ 1884 Tcl_Obj *const objv[]) /* The argument objects. */ 1885{ 1886 register ImportedCmdData *dataPtr = clientData; 1887 register Command *realCmdPtr = dataPtr->realCmdPtr; 1888 1889 return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, 1890 objc, objv); 1891} 1892 1893/* 1894 *---------------------------------------------------------------------- 1895 * 1896 * DeleteImportedCmd -- 1897 * 1898 * Invoked by Tcl whenever an imported command is deleted. The "real" 1899 * command keeps a list of all the imported commands that refer to it, so 1900 * those imported commands can be deleted when the real command is 1901 * deleted. This function removes the imported command reference from the 1902 * real command's list, and frees up the memory associated with the 1903 * imported command. 1904 * 1905 * Results: 1906 * None. 1907 * 1908 * Side effects: 1909 * Removes the imported command from the real command's import list. 1910 * 1911 *---------------------------------------------------------------------- 1912 */ 1913 1914static void 1915DeleteImportedCmd( 1916 ClientData clientData) /* Points to the imported command's 1917 * ImportedCmdData structure. */ 1918{ 1919 ImportedCmdData *dataPtr = clientData; 1920 Command *realCmdPtr = dataPtr->realCmdPtr; 1921 Command *selfPtr = dataPtr->selfPtr; 1922 register ImportRef *refPtr, *prevPtr; 1923 1924 prevPtr = NULL; 1925 for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; 1926 refPtr = refPtr->nextPtr) { 1927 if (refPtr->importedCmdPtr == selfPtr) { 1928 /* 1929 * Remove *refPtr from real command's list of imported commands 1930 * that refer to it. 1931 */ 1932 1933 if (prevPtr == NULL) { /* refPtr is first in list. */ 1934 realCmdPtr->importRefPtr = refPtr->nextPtr; 1935 } else { 1936 prevPtr->nextPtr = refPtr->nextPtr; 1937 } 1938 ckfree((char *) refPtr); 1939 ckfree((char *) dataPtr); 1940 return; 1941 } 1942 prevPtr = refPtr; 1943 } 1944 1945 Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); 1946} 1947 1948/* 1949 *---------------------------------------------------------------------- 1950 * 1951 * TclGetNamespaceForQualName -- 1952 * 1953 * Given a qualified name specifying a command, variable, or namespace, 1954 * and a namespace in which to resolve the name, this function returns a 1955 * pointer to the namespace that contains the item. A qualified name 1956 * consists of the "simple" name of an item qualified by the names of an 1957 * arbitrary number of containing namespace separated by "::"s. If the 1958 * qualified name starts with "::", it is interpreted absolutely from the 1959 * global namespace. Otherwise, it is interpreted relative to the 1960 * namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is 1961 * NULL, the name is interpreted relative to the current namespace. 1962 * 1963 * A relative name like "foo::bar::x" can be found starting in either the 1964 * current namespace or in the global namespace. So each search usually 1965 * follows two tracks, and two possible namespaces are returned. If the 1966 * function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path 1967 * failed. 1968 * 1969 * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is 1970 * sought only in the global :: namespace. The alternate search (also) 1971 * starting from the global namespace is ignored and *altNsPtrPtr is set 1972 * NULL. 1973 * 1974 * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is 1975 * sought only in the namespace specified by cxtNsPtr. The alternate 1976 * search starting from the global namespace is ignored and *altNsPtrPtr 1977 * is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are 1978 * specified, TCL_GLOBAL_ONLY is ignored and the search starts from the 1979 * namespace specified by cxtNsPtr. 1980 * 1981 * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components 1982 * of the qualified name that cannot be found are automatically created 1983 * within their specified parent. This makes sure that functions like 1984 * Tcl_CreateCommand always succeed. There is no alternate search path, 1985 * so *altNsPtrPtr is set NULL. 1986 * 1987 * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as 1988 * a reference to a namespace, and the entire qualified name is followed. 1989 * If the name is relative, the namespace is looked up only in the 1990 * current namespace. A pointer to the namespace is stored in *nsPtrPtr 1991 * and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS 1992 * is not specified, only the leading components are treated as namespace 1993 * names, and a pointer to the simple name of the final component is 1994 * stored in *simpleNamePtr. 1995 * 1996 * Results: 1997 * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible 1998 * namespaces which represent the last (containing) namespace in the 1999 * qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr 2000 * to NULL, then the search along that path failed. The function also 2001 * stores a pointer to the simple name of the final component in 2002 * *simpleNamePtr. If the qualified name is "::" or was treated as a 2003 * namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer 2004 * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets 2005 * *simpleNamePtr to point to an empty string. 2006 * 2007 * If there is an error, this function returns TCL_ERROR. If "flags" 2008 * contains TCL_LEAVE_ERR_MSG, an error message is returned in the 2009 * interpreter's result object. Otherwise, the interpreter's result 2010 * object is left unchanged. 2011 * 2012 * *actualCxtPtrPtr is set to the actual context namespace. It is set to 2013 * the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL, 2014 * it is set to the current namespace context. 2015 * 2016 * For backwards compatibility with the TclPro byte code loader, this 2017 * function always returns TCL_OK. 2018 * 2019 * Side effects: 2020 * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be 2021 * created. 2022 * 2023 *---------------------------------------------------------------------- 2024 */ 2025 2026int 2027TclGetNamespaceForQualName( 2028 Tcl_Interp *interp, /* Interpreter in which to find the namespace 2029 * containing qualName. */ 2030 const char *qualName, /* A namespace-qualified name of an command, 2031 * variable, or namespace. */ 2032 Namespace *cxtNsPtr, /* The namespace in which to start the search 2033 * for qualName's namespace. If NULL start 2034 * from the current namespace. Ignored if 2035 * TCL_GLOBAL_ONLY is set. */ 2036 int flags, /* Flags controlling the search: an OR'd 2037 * combination of TCL_GLOBAL_ONLY, 2038 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and 2039 * TCL_CREATE_NS_IF_UNKNOWN. */ 2040 Namespace **nsPtrPtr, /* Address where function stores a pointer to 2041 * containing namespace if qualName is found 2042 * starting from *cxtNsPtr or, if 2043 * TCL_GLOBAL_ONLY is set, if qualName is 2044 * found in the global :: namespace. NULL is 2045 * stored otherwise. */ 2046 Namespace **altNsPtrPtr, /* Address where function stores a pointer to 2047 * containing namespace if qualName is found 2048 * starting from the global :: namespace. 2049 * NULL is stored if qualName isn't found 2050 * starting from :: or if the TCL_GLOBAL_ONLY, 2051 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, 2052 * TCL_CREATE_NS_IF_UNKNOWN flag is set. */ 2053 Namespace **actualCxtPtrPtr,/* Address where function stores a pointer to 2054 * the actual namespace from which the search 2055 * started. This is either cxtNsPtr, the :: 2056 * namespace if TCL_GLOBAL_ONLY was specified, 2057 * or the current namespace if cxtNsPtr was 2058 * NULL. */ 2059 const char **simpleNamePtr) /* Address where function stores the simple 2060 * name at end of the qualName, or NULL if 2061 * qualName is "::" or the flag 2062 * TCL_FIND_ONLY_NS was specified. */ 2063{ 2064 Interp *iPtr = (Interp *) interp; 2065 Namespace *nsPtr = cxtNsPtr; 2066 Namespace *altNsPtr; 2067 Namespace *globalNsPtr = iPtr->globalNsPtr; 2068 const char *start, *end; 2069 const char *nsName; 2070 Tcl_HashEntry *entryPtr; 2071 Tcl_DString buffer; 2072 int len; 2073 2074 /* 2075 * Determine the context namespace nsPtr in which to start the primary 2076 * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was 2077 * specified, search from the global namespace. Otherwise, use the 2078 * namespace given in cxtNsPtr, or if that is NULL, use the current 2079 * namespace context. Note that we always treat two or more adjacent ":"s 2080 * as a namespace separator. 2081 */ 2082 2083 if (flags & TCL_GLOBAL_ONLY) { 2084 nsPtr = globalNsPtr; 2085 } else if (nsPtr == NULL) { 2086 nsPtr = iPtr->varFramePtr->nsPtr; 2087 } 2088 2089 start = qualName; /* Points to start of qualifying 2090 * namespace. */ 2091 if ((*qualName == ':') && (*(qualName+1) == ':')) { 2092 start = qualName+2; /* Skip over the initial :: */ 2093 while (*start == ':') { 2094 start++; /* Skip over a subsequent : */ 2095 } 2096 nsPtr = globalNsPtr; 2097 if (*start == '\0') { /* qualName is just two or more 2098 * ":"s. */ 2099 *nsPtrPtr = globalNsPtr; 2100 *altNsPtrPtr = NULL; 2101 *actualCxtPtrPtr = globalNsPtr; 2102 *simpleNamePtr = start; /* Points to empty string. */ 2103 return TCL_OK; 2104 } 2105 } 2106 *actualCxtPtrPtr = nsPtr; 2107 2108 /* 2109 * Start an alternate search path starting with the global namespace. 2110 * However, if the starting context is the global namespace, or if the 2111 * flag is set to search only the namespace *cxtNsPtr, ignore the 2112 * alternate search path. 2113 */ 2114 2115 altNsPtr = globalNsPtr; 2116 if ((nsPtr == globalNsPtr) 2117 || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) { 2118 altNsPtr = NULL; 2119 } 2120 2121 /* 2122 * Loop to resolve each namespace qualifier in qualName. 2123 */ 2124 2125 Tcl_DStringInit(&buffer); 2126 end = start; 2127 while (*start != '\0') { 2128 /* 2129 * Find the next namespace qualifier (i.e., a name ending in "::") or 2130 * the end of the qualified name (i.e., a name ending in "\0"). Set 2131 * len to the number of characters, starting from start, in the name; 2132 * set end to point after the "::"s or at the "\0". 2133 */ 2134 2135 len = 0; 2136 for (end = start; *end != '\0'; end++) { 2137 if ((*end == ':') && (*(end+1) == ':')) { 2138 end += 2; /* Skip over the initial :: */ 2139 while (*end == ':') { 2140 end++; /* Skip over the subsequent : */ 2141 } 2142 break; /* Exit for loop; end is after ::'s */ 2143 } 2144 len++; 2145 } 2146 2147 if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { 2148 /* 2149 * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS 2150 * was specified, look this up as a namespace. Otherwise, start is 2151 * the name of a cmd or var and we are done. 2152 */ 2153 2154 if (flags & TCL_FIND_ONLY_NS) { 2155 nsName = start; 2156 } else { 2157 *nsPtrPtr = nsPtr; 2158 *altNsPtrPtr = altNsPtr; 2159 *simpleNamePtr = start; 2160 Tcl_DStringFree(&buffer); 2161 return TCL_OK; 2162 } 2163 } else { 2164 /* 2165 * start points to the beginning of a namespace qualifier ending 2166 * in "::". end points to the start of a name in that namespace 2167 * that might be empty. Copy the namespace qualifier to a buffer 2168 * so it can be null terminated. We can't modify the incoming 2169 * qualName since it may be a string constant. 2170 */ 2171 2172 Tcl_DStringSetLength(&buffer, 0); 2173 Tcl_DStringAppend(&buffer, start, len); 2174 nsName = Tcl_DStringValue(&buffer); 2175 } 2176 2177 /* 2178 * Look up the namespace qualifier nsName in the current namespace 2179 * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set, 2180 * create that qualifying namespace. This is needed for functions like 2181 * Tcl_CreateCommand that cannot fail. 2182 */ 2183 2184 if (nsPtr != NULL) { 2185 entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); 2186 if (entryPtr != NULL) { 2187 nsPtr = Tcl_GetHashValue(entryPtr); 2188 } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) { 2189 Tcl_CallFrame *framePtr; 2190 2191 (void) TclPushStackFrame(interp, &framePtr, 2192 (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); 2193 2194 nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, 2195 NULL, NULL); 2196 TclPopStackFrame(interp); 2197 2198 if (nsPtr == NULL) { 2199 Tcl_Panic("Could not create namespace '%s'", nsName); 2200 } 2201 } else { /* Namespace not found and was not 2202 * created. */ 2203 nsPtr = NULL; 2204 } 2205 } 2206 2207 /* 2208 * Look up the namespace qualifier in the alternate search path too. 2209 */ 2210 2211 if (altNsPtr != NULL) { 2212 entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); 2213 if (entryPtr != NULL) { 2214 altNsPtr = Tcl_GetHashValue(entryPtr); 2215 } else { 2216 altNsPtr = NULL; 2217 } 2218 } 2219 2220 /* 2221 * If both search paths have failed, return NULL results. 2222 */ 2223 2224 if ((nsPtr == NULL) && (altNsPtr == NULL)) { 2225 *nsPtrPtr = NULL; 2226 *altNsPtrPtr = NULL; 2227 *simpleNamePtr = NULL; 2228 Tcl_DStringFree(&buffer); 2229 return TCL_OK; 2230 } 2231 2232 start = end; 2233 } 2234 2235 /* 2236 * We ignore trailing "::"s in a namespace name, but in a command or 2237 * variable name, trailing "::"s refer to the cmd or var named {}. 2238 */ 2239 2240 if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { 2241 *simpleNamePtr = NULL; /* Found namespace name. */ 2242 } else { 2243 *simpleNamePtr = end; /* Found cmd/var: points to empty 2244 * string. */ 2245 } 2246 2247 /* 2248 * As a special case, if we are looking for a namespace and qualName is "" 2249 * and the current active namespace (nsPtr) is not the global namespace, 2250 * return NULL (no namespace was found). This is because namespaces can 2251 * not have empty names except for the global namespace. 2252 */ 2253 2254 if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0') 2255 && (nsPtr != globalNsPtr)) { 2256 nsPtr = NULL; 2257 } 2258 2259 *nsPtrPtr = nsPtr; 2260 *altNsPtrPtr = altNsPtr; 2261 Tcl_DStringFree(&buffer); 2262 return TCL_OK; 2263} 2264 2265/* 2266 *---------------------------------------------------------------------- 2267 * 2268 * Tcl_FindNamespace -- 2269 * 2270 * Searches for a namespace. 2271 * 2272 * Results: 2273 * Returns a pointer to the namespace if it is found. Otherwise, returns 2274 * NULL and leaves an error message in the interpreter's result object if 2275 * "flags" contains TCL_LEAVE_ERR_MSG. 2276 * 2277 * Side effects: 2278 * None. 2279 * 2280 *---------------------------------------------------------------------- 2281 */ 2282 2283Tcl_Namespace * 2284Tcl_FindNamespace( 2285 Tcl_Interp *interp, /* The interpreter in which to find the 2286 * namespace. */ 2287 const char *name, /* Namespace name. If it starts with "::", 2288 * will be looked up in global namespace. 2289 * Else, looked up first in contextNsPtr 2290 * (current namespace if contextNsPtr is 2291 * NULL), then in global namespace. */ 2292 Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or 2293 * if the name starts with "::". Otherwise, 2294 * points to namespace in which to resolve 2295 * name; if NULL, look up name in the current 2296 * namespace. */ 2297 register int flags) /* Flags controlling namespace lookup: an OR'd 2298 * combination of TCL_GLOBAL_ONLY and 2299 * TCL_LEAVE_ERR_MSG flags. */ 2300{ 2301 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; 2302 const char *dummy; 2303 2304 /* 2305 * Find the namespace(s) that contain the specified namespace name. Add 2306 * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its 2307 * last component, a namespace. 2308 */ 2309 2310 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 2311 flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); 2312 2313 if (nsPtr != NULL) { 2314 return (Tcl_Namespace *) nsPtr; 2315 } else if (flags & TCL_LEAVE_ERR_MSG) { 2316 Tcl_ResetResult(interp); 2317 Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL); 2318 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); 2319 } 2320 return NULL; 2321} 2322 2323/* 2324 *---------------------------------------------------------------------- 2325 * 2326 * Tcl_FindCommand -- 2327 * 2328 * Searches for a command. 2329 * 2330 * Results: 2331 * Returns a token for the command if it is found. Otherwise, if it can't 2332 * be found or there is an error, returns NULL and leaves an error 2333 * message in the interpreter's result object if "flags" contains 2334 * TCL_LEAVE_ERR_MSG. 2335 * 2336 * Side effects: 2337 * None. 2338 * 2339 *---------------------------------------------------------------------- 2340 */ 2341 2342Tcl_Command 2343Tcl_FindCommand( 2344 Tcl_Interp *interp, /* The interpreter in which to find the 2345 * command and to report errors. */ 2346 const char *name, /* Command's name. If it starts with "::", 2347 * will be looked up in global namespace. 2348 * Else, looked up first in contextNsPtr 2349 * (current namespace if contextNsPtr is 2350 * NULL), then in global namespace. */ 2351 Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set. 2352 * Otherwise, points to namespace in which to 2353 * resolve name. If NULL, look up name in the 2354 * current namespace. */ 2355 int flags) /* An OR'd combination of flags: 2356 * TCL_GLOBAL_ONLY (look up name only in 2357 * global namespace), TCL_NAMESPACE_ONLY (look 2358 * up only in contextNsPtr, or the current 2359 * namespace if contextNsPtr is NULL), and 2360 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY 2361 * and TCL_NAMESPACE_ONLY are given, 2362 * TCL_GLOBAL_ONLY is ignored. */ 2363{ 2364 Interp *iPtr = (Interp *) interp; 2365 Namespace *cxtNsPtr; 2366 register Tcl_HashEntry *entryPtr; 2367 register Command *cmdPtr; 2368 const char *simpleName; 2369 int result; 2370 2371 /* 2372 * If this namespace has a command resolver, then give it first crack at 2373 * the command resolution. If the interpreter has any command resolvers, 2374 * consult them next. The command resolver functions may return a 2375 * Tcl_Command value, they may signal to continue onward, or they may 2376 * signal an error. 2377 */ 2378 2379 if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) { 2380 cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp); 2381 } else if (contextNsPtr != NULL) { 2382 cxtNsPtr = (Namespace *) contextNsPtr; 2383 } else { 2384 cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp); 2385 } 2386 2387 if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { 2388 ResolverScheme *resPtr = iPtr->resolverPtr; 2389 Tcl_Command cmd; 2390 2391 if (cxtNsPtr->cmdResProc) { 2392 result = (*cxtNsPtr->cmdResProc)(interp, name, 2393 (Tcl_Namespace *) cxtNsPtr, flags, &cmd); 2394 } else { 2395 result = TCL_CONTINUE; 2396 } 2397 2398 while (result == TCL_CONTINUE && resPtr) { 2399 if (resPtr->cmdResProc) { 2400 result = (*resPtr->cmdResProc)(interp, name, 2401 (Tcl_Namespace *) cxtNsPtr, flags, &cmd); 2402 } 2403 resPtr = resPtr->nextPtr; 2404 } 2405 2406 if (result == TCL_OK) { 2407 return cmd; 2408 } else if (result != TCL_CONTINUE) { 2409 return NULL; 2410 } 2411 } 2412 2413 /* 2414 * Find the namespace(s) that contain the command. 2415 */ 2416 2417 cmdPtr = NULL; 2418 if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2) 2419 && !(flags & TCL_NAMESPACE_ONLY)) { 2420 int i; 2421 Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr; 2422 2423 (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr, 2424 TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, 2425 &simpleName); 2426 if ((realNsPtr != NULL) && (simpleName != NULL)) { 2427 if ((cxtNsPtr == realNsPtr) 2428 || !(realNsPtr->flags & NS_DYING)) { 2429 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); 2430 if (entryPtr != NULL) { 2431 cmdPtr = Tcl_GetHashValue(entryPtr); 2432 } 2433 } 2434 } 2435 2436 /* 2437 * Next, check along the path. 2438 */ 2439 2440 for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) { 2441 pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr; 2442 if (pathNsPtr == NULL) { 2443 continue; 2444 } 2445 (void) TclGetNamespaceForQualName(interp, name, pathNsPtr, 2446 TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, 2447 &simpleName); 2448 if ((realNsPtr != NULL) && (simpleName != NULL) 2449 && !(realNsPtr->flags & NS_DYING)) { 2450 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); 2451 if (entryPtr != NULL) { 2452 cmdPtr = Tcl_GetHashValue(entryPtr); 2453 } 2454 } 2455 } 2456 2457 /* 2458 * If we've still not found the command, look in the global namespace 2459 * as a last resort. 2460 */ 2461 2462 if (cmdPtr == NULL) { 2463 (void) TclGetNamespaceForQualName(interp, name, NULL, 2464 TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr, 2465 &simpleName); 2466 if ((realNsPtr != NULL) && (simpleName != NULL) 2467 && !(realNsPtr->flags & NS_DYING)) { 2468 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName); 2469 if (entryPtr != NULL) { 2470 cmdPtr = Tcl_GetHashValue(entryPtr); 2471 } 2472 } 2473 } 2474 } else { 2475 Namespace *nsPtr[2]; 2476 register int search; 2477 2478 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 2479 flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); 2480 2481 /* 2482 * Look for the command in the command table of its namespace. Be sure 2483 * to check both possible search paths: from the specified namespace 2484 * context and from the global namespace. 2485 */ 2486 2487 for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { 2488 if ((nsPtr[search] != NULL) && (simpleName != NULL)) { 2489 entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, 2490 simpleName); 2491 if (entryPtr != NULL) { 2492 cmdPtr = Tcl_GetHashValue(entryPtr); 2493 } 2494 } 2495 } 2496 } 2497 2498 if (cmdPtr != NULL) { 2499 return (Tcl_Command) cmdPtr; 2500 } 2501 2502 if (flags & TCL_LEAVE_ERR_MSG) { 2503 Tcl_ResetResult(interp); 2504 Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL); 2505 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL); 2506 } 2507 return NULL; 2508} 2509 2510/* 2511 *---------------------------------------------------------------------- 2512 * 2513 * TclResetShadowedCmdRefs -- 2514 * 2515 * Called when a command is added to a namespace to check for existing 2516 * command references that the new command may invalidate. Consider the 2517 * following cases that could happen when you add a command "foo" to a 2518 * namespace "b": 2519 * 1. It could shadow a command named "foo" at the global scope. If 2520 * it does, all command references in the namespace "b" are 2521 * suspect. 2522 * 2. Suppose the namespace "b" resides in a namespace "a". Then to 2523 * "a" the new command "b::foo" could shadow another command 2524 * "b::foo" in the global namespace. If so, then all command 2525 * references in "a" * are suspect. 2526 * The same checks are applied to all parent namespaces, until we reach 2527 * the global :: namespace. 2528 * 2529 * Results: 2530 * None. 2531 * 2532 * Side effects: 2533 * If the new command shadows an existing command, the cmdRefEpoch 2534 * counter is incremented in each namespace that sees the shadow. This 2535 * invalidates all command references that were previously cached in that 2536 * namespace. The next time the commands are used, they are resolved from 2537 * scratch. 2538 * 2539 *---------------------------------------------------------------------- 2540 */ 2541 2542void 2543TclResetShadowedCmdRefs( 2544 Tcl_Interp *interp, /* Interpreter containing the new command. */ 2545 Command *newCmdPtr) /* Points to the new command. */ 2546{ 2547 char *cmdName; 2548 Tcl_HashEntry *hPtr; 2549 register Namespace *nsPtr; 2550 Namespace *trailNsPtr, *shadowNsPtr; 2551 Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); 2552 int found, i; 2553 int trailFront = -1; 2554 int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */ 2555 Namespace **trailPtr = (Namespace **) 2556 TclStackAlloc(interp, trailSize * sizeof(Namespace *)); 2557 2558 /* 2559 * Start at the namespace containing the new command, and work up through 2560 * the list of parents. Stop just before the global namespace, since the 2561 * global namespace can't "shadow" its own entries. 2562 * 2563 * The namespace "trail" list we build consists of the names of each 2564 * namespace that encloses the new command, in order from outermost to 2565 * innermost: for example, "a" then "b". Each iteration of this loop 2566 * eventually extends the trail upwards by one namespace, nsPtr. We use 2567 * this trail list to see if nsPtr (e.g. "a" in 2. above) could have 2568 * now-invalid cached command references. This will happen if nsPtr 2569 * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that 2570 * there is a identically-named sequence of child namespaces starting from 2571 * :: (e.g. "::b") whose tail namespace contains a command also named 2572 * cmdName. 2573 */ 2574 2575 cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); 2576 for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ; 2577 nsPtr=nsPtr->parentPtr) { 2578 /* 2579 * Find the maximal sequence of child namespaces contained in nsPtr 2580 * such that there is a identically-named sequence of child namespaces 2581 * starting from ::. shadowNsPtr will be the tail of this sequence, or 2582 * the deepest namespace under :: that might contain a command now 2583 * shadowed by cmdName. We check below if shadowNsPtr actually 2584 * contains a command cmdName. 2585 */ 2586 2587 found = 1; 2588 shadowNsPtr = globalNsPtr; 2589 2590 for (i = trailFront; i >= 0; i--) { 2591 trailNsPtr = trailPtr[i]; 2592 hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, 2593 trailNsPtr->name); 2594 if (hPtr != NULL) { 2595 shadowNsPtr = Tcl_GetHashValue(hPtr); 2596 } else { 2597 found = 0; 2598 break; 2599 } 2600 } 2601 2602 /* 2603 * If shadowNsPtr contains a command named cmdName, we invalidate all 2604 * of the command refs cached in nsPtr. As a boundary case, 2605 * shadowNsPtr is initially :: and we check for case 1. above. 2606 */ 2607 2608 if (found) { 2609 hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); 2610 if (hPtr != NULL) { 2611 nsPtr->cmdRefEpoch++; 2612 TclInvalidateNsPath(nsPtr); 2613 2614 /* 2615 * If the shadowed command was compiled to bytecodes, we 2616 * invalidate all the bytecodes in nsPtr, to force a new 2617 * compilation. We use the resolverEpoch to signal the need 2618 * for a fresh compilation of every bytecode. 2619 */ 2620 2621 if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) { 2622 nsPtr->resolverEpoch++; 2623 } 2624 } 2625 } 2626 2627 /* 2628 * Insert nsPtr at the front of the trail list: i.e., at the end of 2629 * the trailPtr array. 2630 */ 2631 2632 trailFront++; 2633 if (trailFront == trailSize) { 2634 int newSize = 2 * trailSize; 2635 trailPtr = (Namespace **) TclStackRealloc(interp, 2636 trailPtr, newSize * sizeof(Namespace *)); 2637 trailSize = newSize; 2638 } 2639 trailPtr[trailFront] = nsPtr; 2640 } 2641 TclStackFree(interp, trailPtr); 2642} 2643 2644/* 2645 *---------------------------------------------------------------------- 2646 * 2647 * TclGetNamespaceFromObj, GetNamespaceFromObj -- 2648 * 2649 * Gets the namespace specified by the name in a Tcl_Obj. 2650 * 2651 * Results: 2652 * Returns TCL_OK if the namespace was resolved successfully, and stores 2653 * a pointer to the namespace in the location specified by nsPtrPtr. If 2654 * the namespace can't be found, or anything else goes wrong, this 2655 * function returns TCL_ERROR and writes an error message to interp, 2656 * if non-NULL. 2657 * 2658 * Side effects: 2659 * May update the internal representation for the object, caching the 2660 * namespace reference. The next time this function is called, the 2661 * namespace value can be found quickly. 2662 * 2663 *---------------------------------------------------------------------- 2664 */ 2665 2666int 2667TclGetNamespaceFromObj( 2668 Tcl_Interp *interp, /* The current interpreter. */ 2669 Tcl_Obj *objPtr, /* The object to be resolved as the name of a 2670 * namespace. */ 2671 Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ 2672{ 2673 if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) { 2674 const char *name = TclGetString(objPtr); 2675 2676 if ((name[0] == ':') && (name[1] == ':')) { 2677 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 2678 "namespace \"%s\" not found", name)); 2679 } else { 2680 /* 2681 * Get the current namespace name. 2682 */ 2683 2684 NamespaceCurrentCmd(NULL, interp, 2, NULL); 2685 Tcl_SetObjResult(interp, Tcl_ObjPrintf( 2686 "namespace \"%s\" not found in \"%s\"", name, 2687 Tcl_GetStringResult(interp))); 2688 } 2689 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL); 2690 return TCL_ERROR; 2691 } 2692 return TCL_OK; 2693} 2694 2695static int 2696GetNamespaceFromObj( 2697 Tcl_Interp *interp, /* The current interpreter. */ 2698 Tcl_Obj *objPtr, /* The object to be resolved as the name of a 2699 * namespace. */ 2700 Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ 2701{ 2702 ResolvedNsName *resNamePtr; 2703 Namespace *nsPtr, *refNsPtr; 2704 2705 if (objPtr->typePtr == &nsNameType) { 2706 /* 2707 * Check that the ResolvedNsName is still valid; avoid letting the ref 2708 * cross interps. 2709 */ 2710 2711 resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; 2712 nsPtr = resNamePtr->nsPtr; 2713 refNsPtr = resNamePtr->refNsPtr; 2714 if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && 2715 (!refNsPtr || ((interp == refNsPtr->interp) && 2716 (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) { 2717 *nsPtrPtr = (Tcl_Namespace *) nsPtr; 2718 return TCL_OK; 2719 } 2720 } 2721 if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { 2722 resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1; 2723 *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; 2724 return TCL_OK; 2725 } 2726 return TCL_ERROR; 2727} 2728 2729/* 2730 *---------------------------------------------------------------------- 2731 * 2732 * Tcl_NamespaceObjCmd -- 2733 * 2734 * Invoked to implement the "namespace" command that creates, deletes, or 2735 * manipulates Tcl namespaces. Handles the following syntax: 2736 * 2737 * namespace children ?name? ?pattern? 2738 * namespace code arg 2739 * namespace current 2740 * namespace delete ?name name...? 2741 * namespace ensemble subcommand ?arg...? 2742 * namespace eval name arg ?arg...? 2743 * namespace exists name 2744 * namespace export ?-clear? ?pattern pattern...? 2745 * namespace forget ?pattern pattern...? 2746 * namespace import ?-force? ?pattern pattern...? 2747 * namespace inscope name arg ?arg...? 2748 * namespace origin name 2749 * namespace parent ?name? 2750 * namespace qualifiers string 2751 * namespace tail string 2752 * namespace which ?-command? ?-variable? name 2753 * 2754 * Results: 2755 * Returns TCL_OK if the command is successful. Returns TCL_ERROR if 2756 * anything goes wrong. 2757 * 2758 * Side effects: 2759 * Based on the subcommand name (e.g., "import"), this function 2760 * dispatches to a corresponding function NamespaceXXXCmd defined 2761 * statically in this file. This function's side effects depend on 2762 * whatever that subcommand function does. If there is an error, this 2763 * function returns an error message in the interpreter's result object. 2764 * Otherwise it may return a result in the interpreter's result object. 2765 * 2766 *---------------------------------------------------------------------- 2767 */ 2768 2769int 2770Tcl_NamespaceObjCmd( 2771 ClientData clientData, /* Arbitrary value passed to cmd. */ 2772 Tcl_Interp *interp, /* Current interpreter. */ 2773 int objc, /* Number of arguments. */ 2774 Tcl_Obj *const objv[]) /* Argument objects. */ 2775{ 2776 static const char *subCmds[] = { 2777 "children", "code", "current", "delete", "ensemble", 2778 "eval", "exists", "export", "forget", "import", 2779 "inscope", "origin", "parent", "path", "qualifiers", 2780 "tail", "unknown", "upvar", "which", NULL 2781 }; 2782 enum NSSubCmdIdx { 2783 NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx, 2784 NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, 2785 NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx, 2786 NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx 2787 }; 2788 int index, result; 2789 2790 if (objc < 2) { 2791 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); 2792 return TCL_ERROR; 2793 } 2794 2795 /* 2796 * Return an index reflecting the particular subcommand. 2797 */ 2798 2799 result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, 2800 "option", /*flags*/ 0, (int *) &index); 2801 if (result != TCL_OK) { 2802 return result; 2803 } 2804 2805 switch (index) { 2806 case NSChildrenIdx: 2807 result = NamespaceChildrenCmd(clientData, interp, objc, objv); 2808 break; 2809 case NSCodeIdx: 2810 result = NamespaceCodeCmd(clientData, interp, objc, objv); 2811 break; 2812 case NSCurrentIdx: 2813 result = NamespaceCurrentCmd(clientData, interp, objc, objv); 2814 break; 2815 case NSDeleteIdx: 2816 result = NamespaceDeleteCmd(clientData, interp, objc, objv); 2817 break; 2818 case NSEnsembleIdx: 2819 result = NamespaceEnsembleCmd(clientData, interp, objc, objv); 2820 break; 2821 case NSEvalIdx: 2822 result = NamespaceEvalCmd(clientData, interp, objc, objv); 2823 break; 2824 case NSExistsIdx: 2825 result = NamespaceExistsCmd(clientData, interp, objc, objv); 2826 break; 2827 case NSExportIdx: 2828 result = NamespaceExportCmd(clientData, interp, objc, objv); 2829 break; 2830 case NSForgetIdx: 2831 result = NamespaceForgetCmd(clientData, interp, objc, objv); 2832 break; 2833 case NSImportIdx: 2834 result = NamespaceImportCmd(clientData, interp, objc, objv); 2835 break; 2836 case NSInscopeIdx: 2837 result = NamespaceInscopeCmd(clientData, interp, objc, objv); 2838 break; 2839 case NSOriginIdx: 2840 result = NamespaceOriginCmd(clientData, interp, objc, objv); 2841 break; 2842 case NSParentIdx: 2843 result = NamespaceParentCmd(clientData, interp, objc, objv); 2844 break; 2845 case NSPathIdx: 2846 result = NamespacePathCmd(clientData, interp, objc, objv); 2847 break; 2848 case NSQualifiersIdx: 2849 result = NamespaceQualifiersCmd(clientData, interp, objc, objv); 2850 break; 2851 case NSTailIdx: 2852 result = NamespaceTailCmd(clientData, interp, objc, objv); 2853 break; 2854 case NSUpvarIdx: 2855 result = NamespaceUpvarCmd(clientData, interp, objc, objv); 2856 break; 2857 case NSUnknownIdx: 2858 result = NamespaceUnknownCmd(clientData, interp, objc, objv); 2859 break; 2860 case NSWhichIdx: 2861 result = NamespaceWhichCmd(clientData, interp, objc, objv); 2862 break; 2863 } 2864 return result; 2865} 2866 2867/* 2868 *---------------------------------------------------------------------- 2869 * 2870 * NamespaceChildrenCmd -- 2871 * 2872 * Invoked to implement the "namespace children" command that returns a 2873 * list containing the fully-qualified names of the child namespaces of a 2874 * given namespace. Handles the following syntax: 2875 * 2876 * namespace children ?name? ?pattern? 2877 * 2878 * Results: 2879 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2880 * 2881 * Side effects: 2882 * Returns a result in the interpreter's result object. If anything goes 2883 * wrong, the result is an error message. 2884 * 2885 *---------------------------------------------------------------------- 2886 */ 2887 2888static int 2889NamespaceChildrenCmd( 2890 ClientData dummy, /* Not used. */ 2891 Tcl_Interp *interp, /* Current interpreter. */ 2892 int objc, /* Number of arguments. */ 2893 Tcl_Obj *const objv[]) /* Argument objects. */ 2894{ 2895 Tcl_Namespace *namespacePtr; 2896 Namespace *nsPtr, *childNsPtr; 2897 Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp); 2898 char *pattern = NULL; 2899 Tcl_DString buffer; 2900 register Tcl_HashEntry *entryPtr; 2901 Tcl_HashSearch search; 2902 Tcl_Obj *listPtr, *elemPtr; 2903 2904 /* 2905 * Get a pointer to the specified namespace, or the current namespace. 2906 */ 2907 2908 if (objc == 2) { 2909 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 2910 } else if ((objc == 3) || (objc == 4)) { 2911 if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { 2912 return TCL_ERROR; 2913 } 2914 nsPtr = (Namespace *) namespacePtr; 2915 } else { 2916 Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); 2917 return TCL_ERROR; 2918 } 2919 2920 /* 2921 * Get the glob-style pattern, if any, used to narrow the search. 2922 */ 2923 2924 Tcl_DStringInit(&buffer); 2925 if (objc == 4) { 2926 char *name = TclGetString(objv[3]); 2927 2928 if ((*name == ':') && (*(name+1) == ':')) { 2929 pattern = name; 2930 } else { 2931 Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); 2932 if (nsPtr != globalNsPtr) { 2933 Tcl_DStringAppend(&buffer, "::", 2); 2934 } 2935 Tcl_DStringAppend(&buffer, name, -1); 2936 pattern = Tcl_DStringValue(&buffer); 2937 } 2938 } 2939 2940 /* 2941 * Create a list containing the full names of all child namespaces whose 2942 * names match the specified pattern, if any. 2943 */ 2944 2945 listPtr = Tcl_NewListObj(0, NULL); 2946 if ((pattern != NULL) && TclMatchIsTrivial(pattern)) { 2947 unsigned int length = strlen(nsPtr->fullName); 2948 2949 if (strncmp(pattern, nsPtr->fullName, length) != 0) { 2950 goto searchDone; 2951 } 2952 if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) { 2953 Tcl_ListObjAppendElement(interp, listPtr, 2954 Tcl_NewStringObj(pattern, -1)); 2955 } 2956 goto searchDone; 2957 } 2958 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); 2959 while (entryPtr != NULL) { 2960 childNsPtr = Tcl_GetHashValue(entryPtr); 2961 if ((pattern == NULL) 2962 || Tcl_StringMatch(childNsPtr->fullName, pattern)) { 2963 elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); 2964 Tcl_ListObjAppendElement(interp, listPtr, elemPtr); 2965 } 2966 entryPtr = Tcl_NextHashEntry(&search); 2967 } 2968 2969 searchDone: 2970 Tcl_SetObjResult(interp, listPtr); 2971 Tcl_DStringFree(&buffer); 2972 return TCL_OK; 2973} 2974 2975/* 2976 *---------------------------------------------------------------------- 2977 * 2978 * NamespaceCodeCmd -- 2979 * 2980 * Invoked to implement the "namespace code" command to capture the 2981 * namespace context of a command. Handles the following syntax: 2982 * 2983 * namespace code arg 2984 * 2985 * Here "arg" can be a list. "namespace code arg" produces a result 2986 * equivalent to that produced by the command 2987 * 2988 * list ::namespace inscope [namespace current] $arg 2989 * 2990 * However, if "arg" is itself a scoped value starting with "::namespace 2991 * inscope", then the result is just "arg". 2992 * 2993 * Results: 2994 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2995 * 2996 * Side effects: 2997 * If anything goes wrong, this function returns an error message as the 2998 * result in the interpreter's result object. 2999 * 3000 *---------------------------------------------------------------------- 3001 */ 3002 3003static int 3004NamespaceCodeCmd( 3005 ClientData dummy, /* Not used. */ 3006 Tcl_Interp *interp, /* Current interpreter. */ 3007 int objc, /* Number of arguments. */ 3008 Tcl_Obj *const objv[]) /* Argument objects. */ 3009{ 3010 Namespace *currNsPtr; 3011 Tcl_Obj *listPtr, *objPtr; 3012 register char *arg, *p; 3013 int length; 3014 3015 if (objc != 3) { 3016 Tcl_WrongNumArgs(interp, 2, objv, "arg"); 3017 return TCL_ERROR; 3018 } 3019 3020 /* 3021 * If "arg" is already a scoped value, then return it directly. 3022 */ 3023 3024 arg = TclGetStringFromObj(objv[2], &length); 3025 while (*arg == ':') { 3026 arg++; 3027 length--; 3028 } 3029 if (*arg=='n' && length>17 && strncmp(arg, "namespace", 9)==0) { 3030 for (p=arg+9 ; isspace(UCHAR(*p)) ; p++) { 3031 /* empty body: skip over whitespace */ 3032 } 3033 if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) { 3034 Tcl_SetObjResult(interp, objv[2]); 3035 return TCL_OK; 3036 } 3037 } 3038 3039 /* 3040 * Otherwise, construct a scoped command by building a list with 3041 * "namespace inscope", the full name of the current namespace, and the 3042 * argument "arg". By constructing a list, we ensure that scoped commands 3043 * are interpreted properly when they are executed later, by the 3044 * "namespace inscope" command. 3045 */ 3046 3047 TclNewObj(listPtr); 3048 TclNewLiteralStringObj(objPtr, "::namespace"); 3049 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 3050 TclNewLiteralStringObj(objPtr, "inscope"); 3051 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 3052 3053 currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); 3054 if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { 3055 TclNewLiteralStringObj(objPtr, "::"); 3056 } else { 3057 objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); 3058 } 3059 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 3060 3061 Tcl_ListObjAppendElement(interp, listPtr, objv[2]); 3062 3063 Tcl_SetObjResult(interp, listPtr); 3064 return TCL_OK; 3065} 3066 3067/* 3068 *---------------------------------------------------------------------- 3069 * 3070 * NamespaceCurrentCmd -- 3071 * 3072 * Invoked to implement the "namespace current" command which returns the 3073 * fully-qualified name of the current namespace. Handles the following 3074 * syntax: 3075 * 3076 * namespace current 3077 * 3078 * Results: 3079 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3080 * 3081 * Side effects: 3082 * Returns a result in the interpreter's result object. If anything goes 3083 * wrong, the result is an error message. 3084 * 3085 *---------------------------------------------------------------------- 3086 */ 3087 3088static int 3089NamespaceCurrentCmd( 3090 ClientData dummy, /* Not used. */ 3091 Tcl_Interp *interp, /* Current interpreter. */ 3092 int objc, /* Number of arguments. */ 3093 Tcl_Obj *const objv[]) /* Argument objects. */ 3094{ 3095 register Namespace *currNsPtr; 3096 3097 if (objc != 2) { 3098 Tcl_WrongNumArgs(interp, 2, objv, NULL); 3099 return TCL_ERROR; 3100 } 3101 3102 /* 3103 * The "real" name of the global namespace ("::") is the null string, but 3104 * we return "::" for it as a convenience to programmers. Note that "" and 3105 * "::" are treated as synonyms by the namespace code so that it is still 3106 * easy to do things like: 3107 * 3108 * namespace [namespace current]::bar { ... } 3109 */ 3110 3111 currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); 3112 if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) { 3113 Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2)); 3114 } else { 3115 Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1)); 3116 } 3117 return TCL_OK; 3118} 3119 3120/* 3121 *---------------------------------------------------------------------- 3122 * 3123 * NamespaceDeleteCmd -- 3124 * 3125 * Invoked to implement the "namespace delete" command to delete 3126 * namespace(s). Handles the following syntax: 3127 * 3128 * namespace delete ?name name...? 3129 * 3130 * Each name identifies a namespace. It may include a sequence of 3131 * namespace qualifiers separated by "::"s. If a namespace is found, it 3132 * is deleted: all variables and procedures contained in that namespace 3133 * are deleted. If that namespace is being used on the call stack, it is 3134 * kept alive (but logically deleted) until it is removed from the call 3135 * stack: that is, it can no longer be referenced by name but any 3136 * currently executing procedure that refers to it is allowed to do so 3137 * until the procedure returns. If the namespace can't be found, this 3138 * function returns an error. If no namespaces are specified, this 3139 * command does nothing. 3140 * 3141 * Results: 3142 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3143 * 3144 * Side effects: 3145 * Deletes the specified namespaces. If anything goes wrong, this 3146 * function returns an error message in the interpreter's result object. 3147 * 3148 *---------------------------------------------------------------------- 3149 */ 3150 3151static int 3152NamespaceDeleteCmd( 3153 ClientData dummy, /* Not used. */ 3154 Tcl_Interp *interp, /* Current interpreter. */ 3155 int objc, /* Number of arguments. */ 3156 Tcl_Obj *const objv[]) /* Argument objects. */ 3157{ 3158 Tcl_Namespace *namespacePtr; 3159 char *name; 3160 register int i; 3161 3162 if (objc < 2) { 3163 Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); 3164 return TCL_ERROR; 3165 } 3166 3167 /* 3168 * Destroying one namespace may cause another to be destroyed. Break this 3169 * into two passes: first check to make sure that all namespaces on the 3170 * command line are valid, and report any errors. 3171 */ 3172 3173 for (i = 2; i < objc; i++) { 3174 name = TclGetString(objv[i]); 3175 namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0); 3176 if ((namespacePtr == NULL) 3177 || (((Namespace *)namespacePtr)->flags & NS_KILLED)) { 3178 Tcl_AppendResult(interp, "unknown namespace \"", 3179 TclGetString(objv[i]), 3180 "\" in namespace delete command", NULL); 3181 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", 3182 TclGetString(objv[i]), NULL); 3183 return TCL_ERROR; 3184 } 3185 } 3186 3187 /* 3188 * Okay, now delete each namespace. 3189 */ 3190 3191 for (i = 2; i < objc; i++) { 3192 name = TclGetString(objv[i]); 3193 namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0); 3194 if (namespacePtr) { 3195 Tcl_DeleteNamespace(namespacePtr); 3196 } 3197 } 3198 return TCL_OK; 3199} 3200 3201/* 3202 *---------------------------------------------------------------------- 3203 * 3204 * NamespaceEvalCmd -- 3205 * 3206 * Invoked to implement the "namespace eval" command. Executes commands 3207 * in a namespace. If the namespace does not already exist, it is 3208 * created. Handles the following syntax: 3209 * 3210 * namespace eval name arg ?arg...? 3211 * 3212 * If more than one arg argument is specified, the command that is 3213 * executed is the result of concatenating the arguments together with a 3214 * space between each argument. 3215 * 3216 * Results: 3217 * Returns TCL_OK if the namespace is found and the commands are executed 3218 * successfully. Returns TCL_ERROR if anything goes wrong. 3219 * 3220 * Side effects: 3221 * Returns the result of the command in the interpreter's result object. 3222 * If anything goes wrong, this function returns an error message as the 3223 * result. 3224 * 3225 *---------------------------------------------------------------------- 3226 */ 3227 3228static int 3229NamespaceEvalCmd( 3230 ClientData dummy, /* Not used. */ 3231 Tcl_Interp *interp, /* Current interpreter. */ 3232 int objc, /* Number of arguments. */ 3233 Tcl_Obj *const objv[]) /* Argument objects. */ 3234{ 3235 Tcl_Namespace *namespacePtr; 3236 CallFrame *framePtr, **framePtrPtr; 3237 Tcl_Obj *objPtr; 3238 int result; 3239 3240 if (objc < 4) { 3241 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); 3242 return TCL_ERROR; 3243 } 3244 3245 /* 3246 * Try to resolve the namespace reference, caching the result in the 3247 * namespace object along the way. 3248 */ 3249 3250 result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); 3251 3252 /* 3253 * If the namespace wasn't found, try to create it. 3254 */ 3255 3256 if (result == TCL_ERROR) { 3257 char *name = TclGetString(objv[2]); 3258 3259 namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL); 3260 if (namespacePtr == NULL) { 3261 return TCL_ERROR; 3262 } 3263 } 3264 3265 /* 3266 * Make the specified namespace the current namespace and evaluate the 3267 * command(s). 3268 */ 3269 3270 /* This is needed to satisfy GCC 3.3's strict aliasing rules */ 3271 framePtrPtr = &framePtr; 3272 result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, 3273 namespacePtr, /*isProcCallFrame*/ 0); 3274 if (result != TCL_OK) { 3275 return TCL_ERROR; 3276 } 3277 3278 framePtr->objc = objc; 3279 framePtr->objv = objv; 3280 3281 if (objc == 4) { 3282 /* 3283 * TIP #280: Make actual argument location available to eval'd script. 3284 */ 3285 3286 Interp *iPtr = (Interp *) interp; 3287 CmdFrame* invoker = iPtr->cmdFramePtr; 3288 int word = 3; 3289 3290 TclArgumentGet (interp, objv[3], &invoker, &word); 3291 result = TclEvalObjEx(interp, objv[3], 0, invoker, word); 3292 } else { 3293 /* 3294 * More than one argument: concatenate them together with spaces 3295 * between, then evaluate the result. Tcl_EvalObjEx will delete the 3296 * object when it decrements its refcount after eval'ing it. 3297 */ 3298 3299 objPtr = Tcl_ConcatObj(objc-3, objv+3); 3300 3301 /* 3302 * TIP #280: Make invoking context available to eval'd script. 3303 */ 3304 3305 result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); 3306 } 3307 3308 if (result == TCL_ERROR) { 3309 int length = strlen(namespacePtr->fullName); 3310 int limit = 200; 3311 int overflow = (length > limit); 3312 3313 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 3314 "\n (in namespace eval \"%.*s%s\" script line %d)", 3315 (overflow ? limit : length), namespacePtr->fullName, 3316 (overflow ? "..." : ""), interp->errorLine)); 3317 } 3318 3319 /* 3320 * Restore the previous "current" namespace. 3321 */ 3322 3323 TclPopStackFrame(interp); 3324 return result; 3325} 3326 3327/* 3328 *---------------------------------------------------------------------- 3329 * 3330 * NamespaceExistsCmd -- 3331 * 3332 * Invoked to implement the "namespace exists" command that returns true 3333 * if the given namespace currently exists, and false otherwise. Handles 3334 * the following syntax: 3335 * 3336 * namespace exists name 3337 * 3338 * Results: 3339 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3340 * 3341 * Side effects: 3342 * Returns a result in the interpreter's result object. If anything goes 3343 * wrong, the result is an error message. 3344 * 3345 *---------------------------------------------------------------------- 3346 */ 3347 3348static int 3349NamespaceExistsCmd( 3350 ClientData dummy, /* Not used. */ 3351 Tcl_Interp *interp, /* Current interpreter. */ 3352 int objc, /* Number of arguments. */ 3353 Tcl_Obj *const objv[]) /* Argument objects. */ 3354{ 3355 Tcl_Namespace *namespacePtr; 3356 3357 if (objc != 3) { 3358 Tcl_WrongNumArgs(interp, 2, objv, "name"); 3359 return TCL_ERROR; 3360 } 3361 3362 Tcl_SetObjResult(interp, Tcl_NewBooleanObj( 3363 GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK)); 3364 return TCL_OK; 3365} 3366 3367/* 3368 *---------------------------------------------------------------------- 3369 * 3370 * NamespaceExportCmd -- 3371 * 3372 * Invoked to implement the "namespace export" command that specifies 3373 * which commands are exported from a namespace. The exported commands 3374 * are those that can be imported into another namespace using "namespace 3375 * import". Both commands defined in a namespace and commands the 3376 * namespace has imported can be exported by a namespace. This command 3377 * has the following syntax: 3378 * 3379 * namespace export ?-clear? ?pattern pattern...? 3380 * 3381 * Each pattern may contain "string match"-style pattern matching special 3382 * characters, but the pattern may not include any namespace qualifiers: 3383 * that is, the pattern must specify commands in the current (exporting) 3384 * namespace. The specified patterns are appended onto the namespace's 3385 * list of export patterns. 3386 * 3387 * To reset the namespace's export pattern list, specify the "-clear" 3388 * flag. 3389 * 3390 * If there are no export patterns and the "-clear" flag isn't given, 3391 * this command returns the namespace's current export list. 3392 * 3393 * Results: 3394 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3395 * 3396 * Side effects: 3397 * Returns a result in the interpreter's result object. If anything goes 3398 * wrong, the result is an error message. 3399 * 3400 *---------------------------------------------------------------------- 3401 */ 3402 3403static int 3404NamespaceExportCmd( 3405 ClientData dummy, /* Not used. */ 3406 Tcl_Interp *interp, /* Current interpreter. */ 3407 int objc, /* Number of arguments. */ 3408 Tcl_Obj *const objv[]) /* Argument objects. */ 3409{ 3410 Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); 3411 char *pattern, *string; 3412 int resetListFirst = 0; 3413 int firstArg, patternCt, i, result; 3414 3415 if (objc < 2) { 3416 Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?"); 3417 return TCL_ERROR; 3418 } 3419 3420 /* 3421 * Process the optional "-clear" argument. 3422 */ 3423 3424 firstArg = 2; 3425 if (firstArg < objc) { 3426 string = TclGetString(objv[firstArg]); 3427 if (strcmp(string, "-clear") == 0) { 3428 resetListFirst = 1; 3429 firstArg++; 3430 } 3431 } 3432 3433 /* 3434 * If no pattern arguments are given, and "-clear" isn't specified, return 3435 * the namespace's current export pattern list. 3436 */ 3437 3438 patternCt = (objc - firstArg); 3439 if (patternCt == 0) { 3440 if (firstArg > 2) { 3441 return TCL_OK; 3442 } else { 3443 /* 3444 * Create list with export patterns. 3445 */ 3446 3447 Tcl_Obj *listPtr = Tcl_NewListObj(0, NULL); 3448 result = Tcl_AppendExportList(interp, (Tcl_Namespace *) currNsPtr, 3449 listPtr); 3450 if (result != TCL_OK) { 3451 return result; 3452 } 3453 Tcl_SetObjResult(interp, listPtr); 3454 return TCL_OK; 3455 } 3456 } 3457 3458 /* 3459 * Add each pattern to the namespace's export pattern list. 3460 */ 3461 3462 for (i = firstArg; i < objc; i++) { 3463 pattern = TclGetString(objv[i]); 3464 result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, 3465 ((i == firstArg)? resetListFirst : 0)); 3466 if (result != TCL_OK) { 3467 return result; 3468 } 3469 } 3470 return TCL_OK; 3471} 3472 3473/* 3474 *---------------------------------------------------------------------- 3475 * 3476 * NamespaceForgetCmd -- 3477 * 3478 * Invoked to implement the "namespace forget" command to remove imported 3479 * commands from a namespace. Handles the following syntax: 3480 * 3481 * namespace forget ?pattern pattern...? 3482 * 3483 * Each pattern is a name like "foo::*" or "a::b::x*". That is, the 3484 * pattern may include the special pattern matching characters recognized 3485 * by the "string match" command, but only in the command name at the end 3486 * of the qualified name; the special pattern characters may not appear 3487 * in a namespace name. All of the commands that match that pattern are 3488 * checked to see if they have an imported command in the current 3489 * namespace that refers to the matched command. If there is an alias, it 3490 * is removed. 3491 * 3492 * Results: 3493 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3494 * 3495 * Side effects: 3496 * Imported commands are removed from the current namespace. If anything 3497 * goes wrong, this function returns an error message in the 3498 * interpreter's result object. 3499 * 3500 *---------------------------------------------------------------------- 3501 */ 3502 3503static int 3504NamespaceForgetCmd( 3505 ClientData dummy, /* Not used. */ 3506 Tcl_Interp *interp, /* Current interpreter. */ 3507 int objc, /* Number of arguments. */ 3508 Tcl_Obj *const objv[]) /* Argument objects. */ 3509{ 3510 char *pattern; 3511 register int i, result; 3512 3513 if (objc < 2) { 3514 Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); 3515 return TCL_ERROR; 3516 } 3517 3518 for (i = 2; i < objc; i++) { 3519 pattern = TclGetString(objv[i]); 3520 result = Tcl_ForgetImport(interp, NULL, pattern); 3521 if (result != TCL_OK) { 3522 return result; 3523 } 3524 } 3525 return TCL_OK; 3526} 3527 3528/* 3529 *---------------------------------------------------------------------- 3530 * 3531 * NamespaceImportCmd -- 3532 * 3533 * Invoked to implement the "namespace import" command that imports 3534 * commands into a namespace. Handles the following syntax: 3535 * 3536 * namespace import ?-force? ?pattern pattern...? 3537 * 3538 * Each pattern is a namespace-qualified name like "foo::*", "a::b::x*", 3539 * or "bar::p". That is, the pattern may include the special pattern 3540 * matching characters recognized by the "string match" command, but only 3541 * in the command name at the end of the qualified name; the special 3542 * pattern characters may not appear in a namespace name. All of the 3543 * commands that match the pattern and which are exported from their 3544 * namespace are made accessible from the current namespace context. This 3545 * is done by creating a new "imported command" in the current namespace 3546 * that points to the real command in its original namespace; when the 3547 * imported command is called, it invokes the real command. 3548 * 3549 * If an imported command conflicts with an existing command, it is 3550 * treated as an error. But if the "-force" option is included, then 3551 * existing commands are overwritten by the imported commands. 3552 * 3553 * If there are no pattern arguments and the "-force" flag isn't given, 3554 * this command returns the list of commands currently imported in 3555 * the current namespace. 3556 * 3557 * Results: 3558 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3559 * 3560 * Side effects: 3561 * Adds imported commands to the current namespace. If anything goes 3562 * wrong, this function returns an error message in the interpreter's 3563 * result object. 3564 * 3565 *---------------------------------------------------------------------- 3566 */ 3567 3568static int 3569NamespaceImportCmd( 3570 ClientData dummy, /* Not used. */ 3571 Tcl_Interp *interp, /* Current interpreter. */ 3572 int objc, /* Number of arguments. */ 3573 Tcl_Obj *const objv[]) /* Argument objects. */ 3574{ 3575 int allowOverwrite = 0; 3576 char *string, *pattern; 3577 register int i, result; 3578 int firstArg; 3579 3580 if (objc < 2) { 3581 Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?"); 3582 return TCL_ERROR; 3583 } 3584 3585 /* 3586 * Skip over the optional "-force" as the first argument. 3587 */ 3588 3589 firstArg = 2; 3590 if (firstArg < objc) { 3591 string = TclGetString(objv[firstArg]); 3592 if ((*string == '-') && (strcmp(string, "-force") == 0)) { 3593 allowOverwrite = 1; 3594 firstArg++; 3595 } 3596 } else { 3597 /* 3598 * When objc == 2, command is just [namespace import]. Introspection 3599 * form to return list of imported commands. 3600 */ 3601 3602 Tcl_HashEntry *hPtr; 3603 Tcl_HashSearch search; 3604 Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 3605 Tcl_Obj *listPtr; 3606 3607 TclNewObj(listPtr); 3608 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 3609 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { 3610 Command *cmdPtr = Tcl_GetHashValue(hPtr); 3611 3612 if (cmdPtr->deleteProc == DeleteImportedCmd) { 3613 Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj( 3614 Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1)); 3615 } 3616 } 3617 Tcl_SetObjResult(interp, listPtr); 3618 return TCL_OK; 3619 } 3620 3621 /* 3622 * Handle the imports for each of the patterns. 3623 */ 3624 3625 for (i = firstArg; i < objc; i++) { 3626 pattern = TclGetString(objv[i]); 3627 result = Tcl_Import(interp, NULL, pattern, allowOverwrite); 3628 if (result != TCL_OK) { 3629 return result; 3630 } 3631 } 3632 return TCL_OK; 3633} 3634 3635/* 3636 *---------------------------------------------------------------------- 3637 * 3638 * NamespaceInscopeCmd -- 3639 * 3640 * Invoked to implement the "namespace inscope" command that executes a 3641 * script in the context of a particular namespace. This command is not 3642 * expected to be used directly by programmers; calls to it are generated 3643 * implicitly when programs use "namespace code" commands to register 3644 * callback scripts. Handles the following syntax: 3645 * 3646 * namespace inscope name arg ?arg...? 3647 * 3648 * The "namespace inscope" command is much like the "namespace eval" 3649 * command except that it has lappend semantics and the namespace must 3650 * already exist. It treats the first argument as a list, and appends any 3651 * arguments after the first onto the end as proper list elements. For 3652 * example, 3653 * 3654 * namespace inscope ::foo {a b} c d e 3655 * 3656 * is equivalent to 3657 * 3658 * namespace eval ::foo [concat {a b} [list c d e]] 3659 * 3660 * This lappend semantics is important because many callback scripts are 3661 * actually prefixes. 3662 * 3663 * Results: 3664 * Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure. 3665 * 3666 * Side effects: 3667 * Returns a result in the Tcl interpreter's result object. 3668 * 3669 *---------------------------------------------------------------------- 3670 */ 3671 3672static int 3673NamespaceInscopeCmd( 3674 ClientData dummy, /* Not used. */ 3675 Tcl_Interp *interp, /* Current interpreter. */ 3676 int objc, /* Number of arguments. */ 3677 Tcl_Obj *const objv[]) /* Argument objects. */ 3678{ 3679 Tcl_Namespace *namespacePtr; 3680 CallFrame *framePtr, **framePtrPtr; 3681 int i, result; 3682 3683 if (objc < 4) { 3684 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); 3685 return TCL_ERROR; 3686 } 3687 3688 /* 3689 * Resolve the namespace reference. 3690 */ 3691 3692 if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { 3693 return TCL_ERROR; 3694 } 3695 3696 /* 3697 * Make the specified namespace the current namespace. 3698 */ 3699 3700 framePtrPtr = &framePtr; /* This is needed to satisfy GCC's 3701 * strict aliasing rules. */ 3702 result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr, 3703 namespacePtr, /*isProcCallFrame*/ 0); 3704 if (result != TCL_OK) { 3705 return result; 3706 } 3707 3708 framePtr->objc = objc; 3709 framePtr->objv = objv; 3710 3711 /* 3712 * Execute the command. If there is just one argument, just treat it as a 3713 * script and evaluate it. Otherwise, create a list from the arguments 3714 * after the first one, then concatenate the first argument and the list 3715 * of extra arguments to form the command to evaluate. 3716 */ 3717 3718 if (objc == 4) { 3719 result = Tcl_EvalObjEx(interp, objv[3], 0); 3720 } else { 3721 Tcl_Obj *concatObjv[2]; 3722 register Tcl_Obj *listPtr, *cmdObjPtr; 3723 3724 listPtr = Tcl_NewListObj(0, NULL); 3725 for (i = 4; i < objc; i++) { 3726 if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) { 3727 Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */ 3728 return TCL_ERROR; 3729 } 3730 } 3731 3732 concatObjv[0] = objv[3]; 3733 concatObjv[1] = listPtr; 3734 cmdObjPtr = Tcl_ConcatObj(2, concatObjv); 3735 result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); 3736 Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ 3737 } 3738 3739 if (result == TCL_ERROR) { 3740 int length = strlen(namespacePtr->fullName); 3741 int limit = 200; 3742 int overflow = (length > limit); 3743 3744 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 3745 "\n (in namespace inscope \"%.*s%s\" script line %d)", 3746 (overflow ? limit : length), namespacePtr->fullName, 3747 (overflow ? "..." : ""), interp->errorLine)); 3748 } 3749 3750 /* 3751 * Restore the previous "current" namespace. 3752 */ 3753 3754 TclPopStackFrame(interp); 3755 return result; 3756} 3757 3758/* 3759 *---------------------------------------------------------------------- 3760 * 3761 * NamespaceOriginCmd -- 3762 * 3763 * Invoked to implement the "namespace origin" command to return the 3764 * fully-qualified name of the "real" command to which the specified 3765 * "imported command" refers. Handles the following syntax: 3766 * 3767 * namespace origin name 3768 * 3769 * Results: 3770 * An imported command is created in an namespace when that namespace 3771 * imports a command from another namespace. If a command is imported 3772 * into a sequence of namespaces a, b,...,n where each successive 3773 * namespace just imports the command from the previous namespace, this 3774 * command returns the fully-qualified name of the original command in 3775 * the first namespace, a. If "name" does not refer to an alias, its 3776 * fully-qualified name is returned. The returned name is stored in the 3777 * interpreter's result object. This function returns TCL_OK if 3778 * successful, and TCL_ERROR if anything goes wrong. 3779 * 3780 * Side effects: 3781 * If anything goes wrong, this function returns an error message in the 3782 * interpreter's result object. 3783 * 3784 *---------------------------------------------------------------------- 3785 */ 3786 3787static int 3788NamespaceOriginCmd( 3789 ClientData dummy, /* Not used. */ 3790 Tcl_Interp *interp, /* Current interpreter. */ 3791 int objc, /* Number of arguments. */ 3792 Tcl_Obj *const objv[]) /* Argument objects. */ 3793{ 3794 Tcl_Command command, origCommand; 3795 Tcl_Obj *resultPtr; 3796 3797 if (objc != 3) { 3798 Tcl_WrongNumArgs(interp, 2, objv, "name"); 3799 return TCL_ERROR; 3800 } 3801 3802 command = Tcl_GetCommandFromObj(interp, objv[2]); 3803 if (command == NULL) { 3804 Tcl_AppendResult(interp, "invalid command name \"", 3805 TclGetString(objv[2]), "\"", NULL); 3806 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", 3807 TclGetString(objv[2]), NULL); 3808 return TCL_ERROR; 3809 } 3810 origCommand = TclGetOriginalCommand(command); 3811 TclNewObj(resultPtr); 3812 if (origCommand == NULL) { 3813 /* 3814 * The specified command isn't an imported command. Return the 3815 * command's name qualified by the full name of the namespace it was 3816 * defined in. 3817 */ 3818 3819 Tcl_GetCommandFullName(interp, command, resultPtr); 3820 } else { 3821 Tcl_GetCommandFullName(interp, origCommand, resultPtr); 3822 } 3823 Tcl_SetObjResult(interp, resultPtr); 3824 return TCL_OK; 3825} 3826 3827/* 3828 *---------------------------------------------------------------------- 3829 * 3830 * NamespaceParentCmd -- 3831 * 3832 * Invoked to implement the "namespace parent" command that returns the 3833 * fully-qualified name of the parent namespace for a specified 3834 * namespace. Handles the following syntax: 3835 * 3836 * namespace parent ?name? 3837 * 3838 * Results: 3839 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3840 * 3841 * Side effects: 3842 * Returns a result in the interpreter's result object. If anything goes 3843 * wrong, the result is an error message. 3844 * 3845 *---------------------------------------------------------------------- 3846 */ 3847 3848static int 3849NamespaceParentCmd( 3850 ClientData dummy, /* Not used. */ 3851 Tcl_Interp *interp, /* Current interpreter. */ 3852 int objc, /* Number of arguments. */ 3853 Tcl_Obj *const objv[]) /* Argument objects. */ 3854{ 3855 Tcl_Namespace *nsPtr; 3856 3857 if (objc == 2) { 3858 nsPtr = TclGetCurrentNamespace(interp); 3859 } else if (objc == 3) { 3860 if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { 3861 return TCL_ERROR; 3862 } 3863 } else { 3864 Tcl_WrongNumArgs(interp, 2, objv, "?name?"); 3865 return TCL_ERROR; 3866 } 3867 3868 /* 3869 * Report the parent of the specified namespace. 3870 */ 3871 3872 if (nsPtr->parentPtr != NULL) { 3873 Tcl_SetObjResult(interp, Tcl_NewStringObj( 3874 nsPtr->parentPtr->fullName, -1)); 3875 } 3876 return TCL_OK; 3877} 3878 3879/* 3880 *---------------------------------------------------------------------- 3881 * 3882 * NamespacePathCmd -- 3883 * 3884 * Invoked to implement the "namespace path" command that reads and 3885 * writes the current namespace's command resolution path. Has one 3886 * optional argument: if present, it is a list of named namespaces to set 3887 * the path to, and if absent, the current path should be returned. 3888 * Handles the following syntax: 3889 * 3890 * namespace path ?nsList? 3891 * 3892 * Results: 3893 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong 3894 * (most notably if the namespace list contains the name of something 3895 * other than a namespace). In the successful-exit case, may set the 3896 * interpreter result to the list of names of the namespaces on the 3897 * current namespace's path. 3898 * 3899 * Side effects: 3900 * May update the namespace path (triggering a recomputing of all command 3901 * names that depend on the namespace for resolution). 3902 * 3903 *---------------------------------------------------------------------- 3904 */ 3905 3906static int 3907NamespacePathCmd( 3908 ClientData dummy, /* Not used. */ 3909 Tcl_Interp *interp, /* Current interpreter. */ 3910 int objc, /* Number of arguments. */ 3911 Tcl_Obj *const objv[]) /* Argument objects. */ 3912{ 3913 Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 3914 int i, nsObjc, result = TCL_ERROR; 3915 Tcl_Obj **nsObjv; 3916 Tcl_Namespace **namespaceList = NULL; 3917 3918 if (objc > 3) { 3919 Tcl_WrongNumArgs(interp, 2, objv, "?pathList?"); 3920 return TCL_ERROR; 3921 } 3922 3923 /* 3924 * If no path is given, return the current path. 3925 */ 3926 3927 if (objc == 2) { 3928 /* 3929 * Not a very fast way to compute this, but easy to get right. 3930 */ 3931 3932 for (i=0 ; i<nsPtr->commandPathLength ; i++) { 3933 if (nsPtr->commandPathArray[i].nsPtr != NULL) { 3934 Tcl_AppendElement(interp, 3935 nsPtr->commandPathArray[i].nsPtr->fullName); 3936 } 3937 } 3938 return TCL_OK; 3939 } 3940 3941 /* 3942 * There is a path given, so parse it into an array of namespace pointers. 3943 */ 3944 3945 if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) { 3946 goto badNamespace; 3947 } 3948 if (nsObjc != 0) { 3949 namespaceList = (Tcl_Namespace **) 3950 TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc); 3951 3952 for (i=0 ; i<nsObjc ; i++) { 3953 if (TclGetNamespaceFromObj(interp, nsObjv[i], 3954 &namespaceList[i]) != TCL_OK) { 3955 goto badNamespace; 3956 } 3957 } 3958 } 3959 3960 /* 3961 * Now we have the list of valid namespaces, install it as the path. 3962 */ 3963 3964 TclSetNsPath(nsPtr, nsObjc, namespaceList); 3965 3966 result = TCL_OK; 3967 badNamespace: 3968 if (namespaceList != NULL) { 3969 TclStackFree(interp, namespaceList); 3970 } 3971 return result; 3972} 3973 3974/* 3975 *---------------------------------------------------------------------- 3976 * 3977 * TclSetNsPath -- 3978 * 3979 * Sets the namespace command name resolution path to the given list of 3980 * namespaces. If the list is empty (of zero length) the path is set to 3981 * empty and the default old-style behaviour of command name resolution 3982 * is used. 3983 * 3984 * Results: 3985 * nothing 3986 * 3987 * Side effects: 3988 * Invalidates the command name resolution caches for any command 3989 * resolved in the given namespace. 3990 * 3991 *---------------------------------------------------------------------- 3992 */ 3993 3994void 3995TclSetNsPath( 3996 Namespace *nsPtr, /* Namespace whose path is to be set. */ 3997 int pathLength, /* Length of pathAry. */ 3998 Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */ 3999{ 4000 if (pathLength != 0) { 4001 NamespacePathEntry *tmpPathArray = (NamespacePathEntry *) 4002 ckalloc(sizeof(NamespacePathEntry) * pathLength); 4003 int i; 4004 4005 for (i=0 ; i<pathLength ; i++) { 4006 tmpPathArray[i].nsPtr = (Namespace *) pathAry[i]; 4007 tmpPathArray[i].creatorNsPtr = nsPtr; 4008 tmpPathArray[i].prevPtr = NULL; 4009 tmpPathArray[i].nextPtr = 4010 tmpPathArray[i].nsPtr->commandPathSourceList; 4011 if (tmpPathArray[i].nextPtr != NULL) { 4012 tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i]; 4013 } 4014 tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i]; 4015 } 4016 if (nsPtr->commandPathLength != 0) { 4017 UnlinkNsPath(nsPtr); 4018 } 4019 nsPtr->commandPathArray = tmpPathArray; 4020 } else { 4021 if (nsPtr->commandPathLength != 0) { 4022 UnlinkNsPath(nsPtr); 4023 } 4024 } 4025 4026 nsPtr->commandPathLength = pathLength; 4027 nsPtr->cmdRefEpoch++; 4028 nsPtr->resolverEpoch++; 4029} 4030 4031/* 4032 *---------------------------------------------------------------------- 4033 * 4034 * UnlinkNsPath -- 4035 * 4036 * Delete the given namespace's command name resolution path. Only call 4037 * if the path is non-empty. Caller must reset the counter containing the 4038 * path size. 4039 * 4040 * Results: 4041 * nothing 4042 * 4043 * Side effects: 4044 * Deletes the array of path entries and unlinks those path entries from 4045 * the target namespace's list of interested namespaces. 4046 * 4047 *---------------------------------------------------------------------- 4048 */ 4049 4050static void 4051UnlinkNsPath( 4052 Namespace *nsPtr) 4053{ 4054 int i; 4055 for (i=0 ; i<nsPtr->commandPathLength ; i++) { 4056 NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i]; 4057 if (nsPathPtr->prevPtr != NULL) { 4058 nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr; 4059 } 4060 if (nsPathPtr->nextPtr != NULL) { 4061 nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr; 4062 } 4063 if (nsPathPtr->nsPtr != NULL) { 4064 if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) { 4065 nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr; 4066 } 4067 } 4068 } 4069 ckfree((char *) nsPtr->commandPathArray); 4070} 4071 4072/* 4073 *---------------------------------------------------------------------- 4074 * 4075 * TclInvalidateNsPath -- 4076 * 4077 * Invalidate the name resolution caches for all names looked up in 4078 * namespaces whose name path includes the given namespace. 4079 * 4080 * Results: 4081 * nothing 4082 * 4083 * Side effects: 4084 * Increments the command reference epoch in each namespace whose path 4085 * includes the given namespace. This causes any cached resolved names 4086 * whose root cacheing context starts at that namespace to be recomputed 4087 * the next time they are used. 4088 * 4089 *---------------------------------------------------------------------- 4090 */ 4091 4092void 4093TclInvalidateNsPath( 4094 Namespace *nsPtr) 4095{ 4096 NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList; 4097 while (nsPathPtr != NULL) { 4098 if (nsPathPtr->nsPtr != NULL) { 4099 nsPathPtr->creatorNsPtr->cmdRefEpoch++; 4100 } 4101 nsPathPtr = nsPathPtr->nextPtr; 4102 } 4103} 4104 4105/* 4106 *---------------------------------------------------------------------- 4107 * 4108 * NamespaceQualifiersCmd -- 4109 * 4110 * Invoked to implement the "namespace qualifiers" command that returns 4111 * any leading namespace qualifiers in a string. These qualifiers are 4112 * namespace names separated by "::"s. For example, for "::foo::p" this 4113 * command returns "::foo", and for "::" it returns "". This command is 4114 * the complement of the "namespace tail" command. Note that this command 4115 * does not check whether the "namespace" names are, in fact, the names 4116 * of currently defined namespaces. Handles the following syntax: 4117 * 4118 * namespace qualifiers string 4119 * 4120 * Results: 4121 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4122 * 4123 * Side effects: 4124 * Returns a result in the interpreter's result object. If anything goes 4125 * wrong, the result is an error message. 4126 * 4127 *---------------------------------------------------------------------- 4128 */ 4129 4130static int 4131NamespaceQualifiersCmd( 4132 ClientData dummy, /* Not used. */ 4133 Tcl_Interp *interp, /* Current interpreter. */ 4134 int objc, /* Number of arguments. */ 4135 Tcl_Obj *const objv[]) /* Argument objects. */ 4136{ 4137 register char *name, *p; 4138 int length; 4139 4140 if (objc != 3) { 4141 Tcl_WrongNumArgs(interp, 2, objv, "string"); 4142 return TCL_ERROR; 4143 } 4144 4145 /* 4146 * Find the end of the string, then work backward and find the start of 4147 * the last "::" qualifier. 4148 */ 4149 4150 name = TclGetString(objv[2]); 4151 for (p = name; *p != '\0'; p++) { 4152 /* empty body */ 4153 } 4154 while (--p >= name) { 4155 if ((*p == ':') && (p > name) && (*(p-1) == ':')) { 4156 p -= 2; /* Back up over the :: */ 4157 while ((p >= name) && (*p == ':')) { 4158 p--; /* Back up over the preceeding : */ 4159 } 4160 break; 4161 } 4162 } 4163 4164 if (p >= name) { 4165 length = p-name+1; 4166 Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length)); 4167 } 4168 return TCL_OK; 4169} 4170 4171/* 4172 *---------------------------------------------------------------------- 4173 * 4174 * NamespaceUnknownCmd -- 4175 * 4176 * Invoked to implement the "namespace unknown" command (TIP 181) that 4177 * sets or queries a per-namespace unknown command handler. This handler 4178 * is called when command lookup fails (current and global ns). The 4179 * default handler for the global namespace is ::unknown. The default 4180 * handler for other namespaces is to call the global namespace unknown 4181 * handler. Passing an empty list results in resetting the handler to its 4182 * default. 4183 * 4184 * namespace unknown ?handler? 4185 * 4186 * Results: 4187 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4188 * 4189 * Side effects: 4190 * If no handler is specified, returns a result in the interpreter's 4191 * result object, otherwise it sets the unknown handler pointer in the 4192 * current namespace to the script fragment provided. If anything goes 4193 * wrong, the result is an error message. 4194 * 4195 *---------------------------------------------------------------------- 4196 */ 4197 4198static int 4199NamespaceUnknownCmd( 4200 ClientData dummy, /* Not used. */ 4201 Tcl_Interp *interp, /* Current interpreter. */ 4202 int objc, /* Number of arguments. */ 4203 Tcl_Obj *const objv[]) /* Argument objects. */ 4204{ 4205 Tcl_Namespace *currNsPtr; 4206 Tcl_Obj *resultPtr; 4207 int rc; 4208 4209 if (objc > 3) { 4210 Tcl_WrongNumArgs(interp, 2, objv, "?script?"); 4211 return TCL_ERROR; 4212 } 4213 4214 currNsPtr = TclGetCurrentNamespace(interp); 4215 4216 if (objc == 2) { 4217 /* 4218 * Introspection - return the current namespace handler. 4219 */ 4220 4221 resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr); 4222 if (resultPtr == NULL) { 4223 TclNewObj(resultPtr); 4224 } 4225 Tcl_SetObjResult(interp, resultPtr); 4226 } else { 4227 rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]); 4228 if (rc == TCL_OK) { 4229 Tcl_SetObjResult(interp, objv[2]); 4230 } 4231 return rc; 4232 } 4233 return TCL_OK; 4234} 4235 4236/* 4237 *---------------------------------------------------------------------- 4238 * 4239 * Tcl_GetNamespaceUnknownHandler -- 4240 * 4241 * Returns the unknown command handler registered for the given 4242 * namespace. 4243 * 4244 * Results: 4245 * Returns the current unknown command handler, or NULL if none exists 4246 * for the namespace. 4247 * 4248 * Side effects: 4249 * None. 4250 * 4251 *---------------------------------------------------------------------- 4252 */ 4253 4254Tcl_Obj * 4255Tcl_GetNamespaceUnknownHandler( 4256 Tcl_Interp *interp, /* The interpreter in which the namespace 4257 * exists. */ 4258 Tcl_Namespace *nsPtr) /* The namespace. */ 4259{ 4260 Namespace *currNsPtr = (Namespace *)nsPtr; 4261 4262 if (currNsPtr->unknownHandlerPtr == NULL && 4263 currNsPtr == ((Interp *)interp)->globalNsPtr) { 4264 /* 4265 * Default handler for global namespace is "::unknown". For all other 4266 * namespaces, it is NULL (which falls back on the global unknown 4267 * handler). 4268 */ 4269 4270 TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown"); 4271 Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr); 4272 } 4273 return currNsPtr->unknownHandlerPtr; 4274} 4275 4276/* 4277 *---------------------------------------------------------------------- 4278 * 4279 * Tcl_SetNamespaceUnknownHandler -- 4280 * 4281 * Sets the unknown command handler for the given namespace to the 4282 * command prefix passed. 4283 * 4284 * Results: 4285 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4286 * 4287 * Side effects: 4288 * Sets the namespace unknown command handler. If the passed in handler 4289 * is NULL or an empty list, then the handler is reset to its default. If 4290 * an error occurs, then an error message is left in the interpreter 4291 * result. 4292 * 4293 *---------------------------------------------------------------------- 4294 */ 4295 4296int 4297Tcl_SetNamespaceUnknownHandler( 4298 Tcl_Interp *interp, /* Interpreter in which the namespace 4299 * exists. */ 4300 Tcl_Namespace *nsPtr, /* Namespace which is being updated. */ 4301 Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */ 4302{ 4303 int lstlen = 0; 4304 Namespace *currNsPtr = (Namespace *)nsPtr; 4305 4306 /* 4307 * Ensure that we check for errors *first* before we change anything. 4308 */ 4309 4310 if (handlerPtr != NULL) { 4311 if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) { 4312 /* 4313 * Not a list. 4314 */ 4315 4316 return TCL_ERROR; 4317 } 4318 if (lstlen > 0) { 4319 /* 4320 * We are going to be saving this handler. Increment the reference 4321 * count before decrementing the refcount on the previous handler, 4322 * so that nothing strange can happen if we are told to set the 4323 * handler to the previous value. 4324 */ 4325 4326 Tcl_IncrRefCount(handlerPtr); 4327 } 4328 } 4329 4330 /* 4331 * Remove old handler next. 4332 */ 4333 4334 if (currNsPtr->unknownHandlerPtr != NULL) { 4335 Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr); 4336 } 4337 4338 /* 4339 * Install the new handler. 4340 */ 4341 4342 if (lstlen > 0) { 4343 /* 4344 * Just store the handler. It already has the correct reference count. 4345 */ 4346 4347 currNsPtr->unknownHandlerPtr = handlerPtr; 4348 } else { 4349 /* 4350 * If NULL or an empty list is passed, this resets to the default 4351 * handler. 4352 */ 4353 4354 currNsPtr->unknownHandlerPtr = NULL; 4355 } 4356 return TCL_OK; 4357} 4358 4359/* 4360 *---------------------------------------------------------------------- 4361 * 4362 * NamespaceTailCmd -- 4363 * 4364 * Invoked to implement the "namespace tail" command that returns the 4365 * trailing name at the end of a string with "::" namespace qualifiers. 4366 * These qualifiers are namespace names separated by "::"s. For example, 4367 * for "::foo::p" this command returns "p", and for "::" it returns "". 4368 * This command is the complement of the "namespace qualifiers" command. 4369 * Note that this command does not check whether the "namespace" names 4370 * are, in fact, the names of currently defined namespaces. Handles the 4371 * following syntax: 4372 * 4373 * namespace tail string 4374 * 4375 * Results: 4376 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4377 * 4378 * Side effects: 4379 * Returns a result in the interpreter's result object. If anything goes 4380 * wrong, the result is an error message. 4381 * 4382 *---------------------------------------------------------------------- 4383 */ 4384 4385static int 4386NamespaceTailCmd( 4387 ClientData dummy, /* Not used. */ 4388 Tcl_Interp *interp, /* Current interpreter. */ 4389 int objc, /* Number of arguments. */ 4390 Tcl_Obj *const objv[]) /* Argument objects. */ 4391{ 4392 register char *name, *p; 4393 4394 if (objc != 3) { 4395 Tcl_WrongNumArgs(interp, 2, objv, "string"); 4396 return TCL_ERROR; 4397 } 4398 4399 /* 4400 * Find the end of the string, then work backward and find the last "::" 4401 * qualifier. 4402 */ 4403 4404 name = TclGetString(objv[2]); 4405 for (p = name; *p != '\0'; p++) { 4406 /* empty body */ 4407 } 4408 while (--p > name) { 4409 if ((*p == ':') && (*(p-1) == ':')) { 4410 p++; /* Just after the last "::" */ 4411 break; 4412 } 4413 } 4414 4415 if (p >= name) { 4416 Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1)); 4417 } 4418 return TCL_OK; 4419} 4420 4421/* 4422 *---------------------------------------------------------------------- 4423 * 4424 * NamespaceUpvarCmd -- 4425 * 4426 * Invoked to implement the "namespace upvar" command, that creates 4427 * variables in the current scope linked to variables in another 4428 * namespace. Handles the following syntax: 4429 * 4430 * namespace upvar ns otherVar myVar ?otherVar myVar ...? 4431 * 4432 * Results: 4433 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4434 * 4435 * Side effects: 4436 * Creates new variables in the current scope, linked to the 4437 * corresponding variables in the stipulated nmamespace. If anything goes 4438 * wrong, the result is an error message. 4439 * 4440 *---------------------------------------------------------------------- 4441 */ 4442 4443static int 4444NamespaceUpvarCmd( 4445 ClientData dummy, /* Not used. */ 4446 Tcl_Interp *interp, /* Current interpreter. */ 4447 int objc, /* Number of arguments. */ 4448 Tcl_Obj *const objv[]) /* Argument objects. */ 4449{ 4450 Interp *iPtr = (Interp *) interp; 4451 Tcl_Namespace *nsPtr, *savedNsPtr; 4452 Var *otherPtr, *arrayPtr; 4453 char *myName; 4454 4455 if (objc < 5 || !(objc & 1)) { 4456 Tcl_WrongNumArgs(interp, 2, objv, 4457 "ns otherVar myVar ?otherVar myVar ...?"); 4458 return TCL_ERROR; 4459 } 4460 4461 if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) { 4462 return TCL_ERROR; 4463 } 4464 4465 objc -= 3; 4466 objv += 3; 4467 4468 for (; objc>0 ; objc-=2, objv+=2) { 4469 /* 4470 * Locate the other variable 4471 */ 4472 4473 savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; 4474 iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; 4475 otherPtr = TclObjLookupVarEx(interp, objv[0], NULL, 4476 (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", 4477 /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); 4478 iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; 4479 if (otherPtr == NULL) { 4480 return TCL_ERROR; 4481 } 4482 4483 /* 4484 * Create the new variable and link it to otherPtr. 4485 */ 4486 4487 myName = TclGetString(objv[1]); 4488 if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) { 4489 return TCL_ERROR; 4490 } 4491 } 4492 4493 return TCL_OK; 4494} 4495 4496/* 4497 *---------------------------------------------------------------------- 4498 * 4499 * NamespaceWhichCmd -- 4500 * 4501 * Invoked to implement the "namespace which" command that returns the 4502 * fully-qualified name of a command or variable. If the specified 4503 * command or variable does not exist, it returns "". Handles the 4504 * following syntax: 4505 * 4506 * namespace which ?-command? ?-variable? name 4507 * 4508 * Results: 4509 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4510 * 4511 * Side effects: 4512 * Returns a result in the interpreter's result object. If anything goes 4513 * wrong, the result is an error message. 4514 * 4515 *---------------------------------------------------------------------- 4516 */ 4517 4518static int 4519NamespaceWhichCmd( 4520 ClientData dummy, /* Not used. */ 4521 Tcl_Interp *interp, /* Current interpreter. */ 4522 int objc, /* Number of arguments. */ 4523 Tcl_Obj *const objv[]) /* Argument objects. */ 4524{ 4525 static const char *opts[] = { 4526 "-command", "-variable", NULL 4527 }; 4528 int lookupType = 0; 4529 Tcl_Obj *resultPtr; 4530 4531 if (objc < 3 || objc > 4) { 4532 badArgs: 4533 Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name"); 4534 return TCL_ERROR; 4535 } else if (objc == 4) { 4536 /* 4537 * Look for a flag controlling the lookup. 4538 */ 4539 4540 if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0, 4541 &lookupType) != TCL_OK) { 4542 /* 4543 * Preserve old style of error message! 4544 */ 4545 4546 Tcl_ResetResult(interp); 4547 goto badArgs; 4548 } 4549 } 4550 4551 TclNewObj(resultPtr); 4552 switch (lookupType) { 4553 case 0: { /* -command */ 4554 Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); 4555 4556 if (cmd != NULL) { 4557 Tcl_GetCommandFullName(interp, cmd, resultPtr); 4558 } 4559 break; 4560 } 4561 case 1: { /* -variable */ 4562 Tcl_Var var = Tcl_FindNamespaceVar(interp, 4563 TclGetString(objv[objc-1]), NULL, /*flags*/ 0); 4564 4565 if (var != NULL) { 4566 Tcl_GetVariableFullName(interp, var, resultPtr); 4567 } 4568 break; 4569 } 4570 } 4571 Tcl_SetObjResult(interp, resultPtr); 4572 return TCL_OK; 4573} 4574 4575/* 4576 *---------------------------------------------------------------------- 4577 * 4578 * FreeNsNameInternalRep -- 4579 * 4580 * Frees the resources associated with a nsName object's internal 4581 * representation. 4582 * 4583 * Results: 4584 * None. 4585 * 4586 * Side effects: 4587 * Decrements the ref count of any Namespace structure pointed to by the 4588 * nsName's internal representation. If there are no more references to 4589 * the namespace, it's structure will be freed. 4590 * 4591 *---------------------------------------------------------------------- 4592 */ 4593 4594static void 4595FreeNsNameInternalRep( 4596 register Tcl_Obj *objPtr) /* nsName object with internal representation 4597 * to free. */ 4598{ 4599 register ResolvedNsName *resNamePtr = (ResolvedNsName *) 4600 objPtr->internalRep.twoPtrValue.ptr1; 4601 Namespace *nsPtr; 4602 4603 /* 4604 * Decrement the reference count of the namespace. If there are no more 4605 * references, free it up. 4606 */ 4607 4608 resNamePtr->refCount--; 4609 if (resNamePtr->refCount == 0) { 4610 4611 /* 4612 * Decrement the reference count for the cached namespace. If the 4613 * namespace is dead, and there are no more references to it, free 4614 * it. 4615 */ 4616 4617 nsPtr = resNamePtr->nsPtr; 4618 nsPtr->refCount--; 4619 if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { 4620 NamespaceFree(nsPtr); 4621 } 4622 ckfree((char *) resNamePtr); 4623 } 4624} 4625 4626/* 4627 *---------------------------------------------------------------------- 4628 * 4629 * DupNsNameInternalRep -- 4630 * 4631 * Initializes the internal representation of a nsName object to a copy 4632 * of the internal representation of another nsName object. 4633 * 4634 * Results: 4635 * None. 4636 * 4637 * Side effects: 4638 * copyPtr's internal rep is set to refer to the same namespace 4639 * referenced by srcPtr's internal rep. Increments the ref count of the 4640 * ResolvedNsName structure used to hold the namespace reference. 4641 * 4642 *---------------------------------------------------------------------- 4643 */ 4644 4645static void 4646DupNsNameInternalRep( 4647 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ 4648 register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ 4649{ 4650 register ResolvedNsName *resNamePtr = (ResolvedNsName *) 4651 srcPtr->internalRep.twoPtrValue.ptr1; 4652 4653 copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; 4654 resNamePtr->refCount++; 4655 copyPtr->typePtr = &nsNameType; 4656} 4657 4658/* 4659 *---------------------------------------------------------------------- 4660 * 4661 * SetNsNameFromAny -- 4662 * 4663 * Attempt to generate a nsName internal representation for a Tcl object. 4664 * 4665 * Results: 4666 * Returns TCL_OK if the value could be converted to a proper namespace 4667 * reference. Otherwise, it returns TCL_ERROR, along with an error 4668 * message in the interpreter's result object. 4669 * 4670 * Side effects: 4671 * If successful, the object is made a nsName object. Its internal rep is 4672 * set to point to a ResolvedNsName, which contains a cached pointer to 4673 * the Namespace. Reference counts are kept on both the ResolvedNsName 4674 * and the Namespace, so we can keep track of their usage and free them 4675 * when appropriate. 4676 * 4677 *---------------------------------------------------------------------- 4678 */ 4679 4680static int 4681SetNsNameFromAny( 4682 Tcl_Interp *interp, /* Points to the namespace in which to resolve 4683 * name. Also used for error reporting if not 4684 * NULL. */ 4685 register Tcl_Obj *objPtr) /* The object to convert. */ 4686{ 4687 const char *dummy; 4688 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; 4689 register ResolvedNsName *resNamePtr; 4690 const char *name = TclGetString(objPtr); 4691 4692 TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, 4693 &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); 4694 4695 /* 4696 * If we found a namespace, then create a new ResolvedNsName structure 4697 * that holds a reference to it. 4698 */ 4699 4700 if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { 4701 /* 4702 * Our failed lookup proves any previously cached nsName intrep is no 4703 * longer valid. Get rid of it so we no longer waste memory storing 4704 * it, nor time determining its invalidity again and again. 4705 */ 4706 4707 if (objPtr->typePtr == &nsNameType) { 4708 TclFreeIntRep(objPtr); 4709 objPtr->typePtr = NULL; 4710 } 4711 return TCL_ERROR; 4712 } 4713 4714 nsPtr->refCount++; 4715 resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); 4716 resNamePtr->nsPtr = nsPtr; 4717 if ((name[0] == ':') && (name[1] == ':')) { 4718 resNamePtr->refNsPtr = NULL; 4719 } else { 4720 resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 4721 } 4722 resNamePtr->refCount = 1; 4723 TclFreeIntRep(objPtr); 4724 objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; 4725 objPtr->typePtr = &nsNameType; 4726 return TCL_OK; 4727} 4728 4729/* 4730 *---------------------------------------------------------------------- 4731 * 4732 * NamespaceEnsembleCmd -- 4733 * 4734 * Invoked to implement the "namespace ensemble" command that creates and 4735 * manipulates ensembles built on top of namespaces. Handles the 4736 * following syntax: 4737 * 4738 * namespace ensemble name ?dictionary? 4739 * 4740 * Results: 4741 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 4742 * 4743 * Side effects: 4744 * Creates the ensemble for the namespace if one did not previously 4745 * exist. Alternatively, alters the way that the ensemble's subcommand => 4746 * implementation prefix is configured. 4747 * 4748 *---------------------------------------------------------------------- 4749 */ 4750 4751static int 4752NamespaceEnsembleCmd( 4753 ClientData dummy, 4754 Tcl_Interp *interp, 4755 int objc, 4756 Tcl_Obj *const objv[]) 4757{ 4758 Namespace *nsPtr; 4759 Tcl_Command token; 4760 static const char *subcommands[] = { 4761 "configure", "create", "exists", NULL 4762 }; 4763 enum EnsSubcmds { 4764 ENS_CONFIG, ENS_CREATE, ENS_EXISTS 4765 }; 4766 static const char *createOptions[] = { 4767 "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL 4768 }; 4769 enum EnsCreateOpts { 4770 CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN 4771 }; 4772 static const char *configOptions[] = { 4773 "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL 4774 }; 4775 enum EnsConfigOpts { 4776 CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN 4777 }; 4778 int index; 4779 4780 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 4781 if (nsPtr == NULL || nsPtr->flags & NS_DYING) { 4782 if (!Tcl_InterpDeleted(interp)) { 4783 Tcl_AppendResult(interp, 4784 "tried to manipulate ensemble of deleted namespace", NULL); 4785 } 4786 return TCL_ERROR; 4787 } 4788 4789 if (objc < 3) { 4790 Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?"); 4791 return TCL_ERROR; 4792 } 4793 if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0, 4794 &index) != TCL_OK) { 4795 return TCL_ERROR; 4796 } 4797 4798 switch ((enum EnsSubcmds) index) { 4799 case ENS_CREATE: { 4800 char *name; 4801 Tcl_DictSearch search; 4802 Tcl_Obj *listObj; 4803 int done, len, allocatedMapFlag = 0; 4804 /* 4805 * Defaults 4806 */ 4807 Tcl_Obj *subcmdObj = NULL; 4808 Tcl_Obj *mapObj = NULL; 4809 int permitPrefix = 1; 4810 Tcl_Obj *unknownObj = NULL; 4811 4812 objv += 3; 4813 objc -= 3; 4814 4815 /* 4816 * Work out what name to use for the command to create. If supplied, 4817 * it is either fully specified or relative to the current namespace. 4818 * If not supplied, it is exactly the name of the current namespace. 4819 */ 4820 4821 name = nsPtr->fullName; 4822 4823 /* 4824 * Parse the option list, applying type checks as we go. Note that we 4825 * are not incrementing any reference counts in the objects at this 4826 * stage, so the presence of an option multiple times won't cause any 4827 * memory leaks. 4828 */ 4829 4830 for (; objc>1 ; objc-=2,objv+=2 ) { 4831 if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option", 4832 0, &index) != TCL_OK) { 4833 if (allocatedMapFlag) { 4834 Tcl_DecrRefCount(mapObj); 4835 } 4836 return TCL_ERROR; 4837 } 4838 switch ((enum EnsCreateOpts) index) { 4839 case CRT_CMD: 4840 name = TclGetString(objv[1]); 4841 continue; 4842 case CRT_SUBCMDS: 4843 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { 4844 if (allocatedMapFlag) { 4845 Tcl_DecrRefCount(mapObj); 4846 } 4847 return TCL_ERROR; 4848 } 4849 subcmdObj = (len > 0 ? objv[1] : NULL); 4850 continue; 4851 case CRT_MAP: { 4852 Tcl_Obj *patchedDict = NULL, *subcmdObj; 4853 4854 /* 4855 * Verify that the map is sensible. 4856 */ 4857 4858 if (Tcl_DictObjFirst(interp, objv[1], &search, 4859 &subcmdObj, &listObj, &done) != TCL_OK) { 4860 if (allocatedMapFlag) { 4861 Tcl_DecrRefCount(mapObj); 4862 } 4863 return TCL_ERROR; 4864 } 4865 if (done) { 4866 mapObj = NULL; 4867 continue; 4868 } 4869 do { 4870 Tcl_Obj **listv; 4871 char *cmd; 4872 4873 if (TclListObjGetElements(interp, listObj, &len, 4874 &listv) != TCL_OK) { 4875 Tcl_DictObjDone(&search); 4876 if (patchedDict) { 4877 Tcl_DecrRefCount(patchedDict); 4878 } 4879 if (allocatedMapFlag) { 4880 Tcl_DecrRefCount(mapObj); 4881 } 4882 return TCL_ERROR; 4883 } 4884 if (len < 1) { 4885 Tcl_SetResult(interp, 4886 "ensemble subcommand implementations " 4887 "must be non-empty lists", TCL_STATIC); 4888 Tcl_DictObjDone(&search); 4889 if (patchedDict) { 4890 Tcl_DecrRefCount(patchedDict); 4891 } 4892 if (allocatedMapFlag) { 4893 Tcl_DecrRefCount(mapObj); 4894 } 4895 return TCL_ERROR; 4896 } 4897 cmd = TclGetString(listv[0]); 4898 if (!(cmd[0] == ':' && cmd[1] == ':')) { 4899 Tcl_Obj *newList = Tcl_NewListObj(len, listv); 4900 Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1); 4901 4902 if (nsPtr->parentPtr) { 4903 Tcl_AppendStringsToObj(newCmd, "::", NULL); 4904 } 4905 Tcl_AppendObjToObj(newCmd, listv[0]); 4906 Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd); 4907 if (patchedDict == NULL) { 4908 patchedDict = Tcl_DuplicateObj(objv[1]); 4909 } 4910 Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList); 4911 } 4912 Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); 4913 } while (!done); 4914 4915 if (allocatedMapFlag) { 4916 Tcl_DecrRefCount(mapObj); 4917 } 4918 mapObj = (patchedDict ? patchedDict : objv[1]); 4919 if (patchedDict) { 4920 allocatedMapFlag = 1; 4921 } 4922 continue; 4923 } 4924 case CRT_PREFIX: 4925 if (Tcl_GetBooleanFromObj(interp, objv[1], 4926 &permitPrefix) != TCL_OK) { 4927 if (allocatedMapFlag) { 4928 Tcl_DecrRefCount(mapObj); 4929 } 4930 return TCL_ERROR; 4931 } 4932 continue; 4933 case CRT_UNKNOWN: 4934 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { 4935 if (allocatedMapFlag) { 4936 Tcl_DecrRefCount(mapObj); 4937 } 4938 return TCL_ERROR; 4939 } 4940 unknownObj = (len > 0 ? objv[1] : NULL); 4941 continue; 4942 } 4943 } 4944 4945 /* 4946 * Create the ensemble. Note that this might delete another ensemble 4947 * linked to the same namespace, so we must be careful. However, we 4948 * should be OK because we only link the namespace into the list once 4949 * we've created it (and after any deletions have occurred.) 4950 */ 4951 4952 token = Tcl_CreateEnsemble(interp, name, NULL, 4953 (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); 4954 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); 4955 Tcl_SetEnsembleMappingDict(interp, token, mapObj); 4956 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); 4957 4958 /* 4959 * Tricky! Must ensure that the result is not shared (command delete 4960 * traces could have corrupted the pristine object that we started 4961 * with). [Snit test rename-1.5] 4962 */ 4963 4964 Tcl_ResetResult(interp); 4965 Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); 4966 return TCL_OK; 4967 } 4968 4969 case ENS_EXISTS: 4970 if (objc != 4) { 4971 Tcl_WrongNumArgs(interp, 3, objv, "cmdname"); 4972 return TCL_ERROR; 4973 } 4974 Tcl_SetObjResult(interp, Tcl_NewBooleanObj( 4975 Tcl_FindEnsemble(interp, objv[3], 0) != NULL)); 4976 return TCL_OK; 4977 4978 case ENS_CONFIG: 4979 if (objc < 4 || (objc != 5 && objc & 1)) { 4980 Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ..."); 4981 return TCL_ERROR; 4982 } 4983 token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG); 4984 if (token == NULL) { 4985 return TCL_ERROR; 4986 } 4987 4988 if (objc == 5) { 4989 Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ 4990 4991 if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option", 4992 0, &index) != TCL_OK) { 4993 return TCL_ERROR; 4994 } 4995 switch ((enum EnsConfigOpts) index) { 4996 case CONF_SUBCMDS: 4997 Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); 4998 if (resultObj != NULL) { 4999 Tcl_SetObjResult(interp, resultObj); 5000 } 5001 break; 5002 case CONF_MAP: 5003 Tcl_GetEnsembleMappingDict(NULL, token, &resultObj); 5004 if (resultObj != NULL) { 5005 Tcl_SetObjResult(interp, resultObj); 5006 } 5007 break; 5008 case CONF_NAMESPACE: { 5009 Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ 5010 5011 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); 5012 Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName, 5013 TCL_VOLATILE); 5014 break; 5015 } 5016 case CONF_PREFIX: { 5017 int flags = 0; /* silence gcc 4 warning */ 5018 5019 Tcl_GetEnsembleFlags(NULL, token, &flags); 5020 Tcl_SetObjResult(interp, 5021 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); 5022 break; 5023 } 5024 case CONF_UNKNOWN: 5025 Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj); 5026 if (resultObj != NULL) { 5027 Tcl_SetObjResult(interp, resultObj); 5028 } 5029 break; 5030 } 5031 return TCL_OK; 5032 5033 } else if (objc == 4) { 5034 /* 5035 * Produce list of all information. 5036 */ 5037 5038 Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */ 5039 Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */ 5040 int flags = 0; /* silence gcc 4 warning */ 5041 5042 TclNewObj(resultObj); 5043 5044 /* -map option */ 5045 Tcl_ListObjAppendElement(NULL, resultObj, 5046 Tcl_NewStringObj(configOptions[CONF_MAP], -1)); 5047 Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj); 5048 Tcl_ListObjAppendElement(NULL, resultObj, 5049 (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); 5050 5051 /* -namespace option */ 5052 Tcl_ListObjAppendElement(NULL, resultObj, 5053 Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1)); 5054 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr); 5055 Tcl_ListObjAppendElement(NULL, resultObj, 5056 Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName, 5057 -1)); 5058 5059 /* -prefix option */ 5060 Tcl_ListObjAppendElement(NULL, resultObj, 5061 Tcl_NewStringObj(configOptions[CONF_PREFIX], -1)); 5062 Tcl_GetEnsembleFlags(NULL, token, &flags); 5063 Tcl_ListObjAppendElement(NULL, resultObj, 5064 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX)); 5065 5066 /* -subcommands option */ 5067 Tcl_ListObjAppendElement(NULL, resultObj, 5068 Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1)); 5069 Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj); 5070 Tcl_ListObjAppendElement(NULL, resultObj, 5071 (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); 5072 5073 /* -unknown option */ 5074 Tcl_ListObjAppendElement(NULL, resultObj, 5075 Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1)); 5076 Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj); 5077 Tcl_ListObjAppendElement(NULL, resultObj, 5078 (tmpObj != NULL) ? tmpObj : Tcl_NewObj()); 5079 5080 Tcl_SetObjResult(interp, resultObj); 5081 return TCL_OK; 5082 } else { 5083 Tcl_DictSearch search; 5084 Tcl_Obj *listObj; 5085 int done, len, allocatedMapFlag = 0; 5086 Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, 5087 *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */ 5088 int permitPrefix, flags = 0; /* silence gcc 4 warning */ 5089 5090 Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); 5091 Tcl_GetEnsembleMappingDict(NULL, token, &mapObj); 5092 Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj); 5093 Tcl_GetEnsembleFlags(NULL, token, &flags); 5094 permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0; 5095 5096 objv += 4; 5097 objc -= 4; 5098 5099 /* 5100 * Parse the option list, applying type checks as we go. Note that 5101 * we are not incrementing any reference counts in the objects at 5102 * this stage, so the presence of an option multiple times won't 5103 * cause any memory leaks. 5104 */ 5105 5106 for (; objc>0 ; objc-=2,objv+=2 ) { 5107 if (Tcl_GetIndexFromObj(interp, objv[0], configOptions, 5108 "option", 0, &index) != TCL_OK) { 5109 if (allocatedMapFlag) { 5110 Tcl_DecrRefCount(mapObj); 5111 } 5112 return TCL_ERROR; 5113 } 5114 switch ((enum EnsConfigOpts) index) { 5115 case CONF_SUBCMDS: 5116 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { 5117 if (allocatedMapFlag) { 5118 Tcl_DecrRefCount(mapObj); 5119 } 5120 return TCL_ERROR; 5121 } 5122 subcmdObj = (len > 0 ? objv[1] : NULL); 5123 continue; 5124 case CONF_MAP: { 5125 Tcl_Obj *patchedDict = NULL, *subcmdObj; 5126 5127 /* 5128 * Verify that the map is sensible. 5129 */ 5130 5131 if (Tcl_DictObjFirst(interp, objv[1], &search, 5132 &subcmdObj, &listObj, &done) != TCL_OK) { 5133 if (allocatedMapFlag) { 5134 Tcl_DecrRefCount(mapObj); 5135 } 5136 return TCL_ERROR; 5137 } 5138 if (done) { 5139 mapObj = NULL; 5140 continue; 5141 } 5142 do { 5143 Tcl_Obj **listv; 5144 char *cmd; 5145 5146 if (TclListObjGetElements(interp, listObj, &len, 5147 &listv) != TCL_OK) { 5148 Tcl_DictObjDone(&search); 5149 if (patchedDict) { 5150 Tcl_DecrRefCount(patchedDict); 5151 } 5152 if (allocatedMapFlag) { 5153 Tcl_DecrRefCount(mapObj); 5154 } 5155 return TCL_ERROR; 5156 } 5157 if (len < 1) { 5158 Tcl_SetResult(interp, 5159 "ensemble subcommand implementations " 5160 "must be non-empty lists", TCL_STATIC); 5161 Tcl_DictObjDone(&search); 5162 if (patchedDict) { 5163 Tcl_DecrRefCount(patchedDict); 5164 } 5165 if (allocatedMapFlag) { 5166 Tcl_DecrRefCount(mapObj); 5167 } 5168 return TCL_ERROR; 5169 } 5170 cmd = TclGetString(listv[0]); 5171 if (!(cmd[0] == ':' && cmd[1] == ':')) { 5172 Tcl_Obj *newList = Tcl_NewListObj(len, listv); 5173 Tcl_Obj *newCmd = 5174 Tcl_NewStringObj(nsPtr->fullName, -1); 5175 if (nsPtr->parentPtr) { 5176 Tcl_AppendStringsToObj(newCmd, "::", NULL); 5177 } 5178 Tcl_AppendObjToObj(newCmd, listv[0]); 5179 Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); 5180 if (patchedDict == NULL) { 5181 patchedDict = Tcl_DuplicateObj(objv[1]); 5182 } 5183 Tcl_DictObjPut(NULL, patchedDict, subcmdObj, 5184 newList); 5185 } 5186 Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done); 5187 } while (!done); 5188 if (allocatedMapFlag) { 5189 Tcl_DecrRefCount(mapObj); 5190 } 5191 mapObj = (patchedDict ? patchedDict : objv[1]); 5192 if (patchedDict) { 5193 allocatedMapFlag = 1; 5194 } 5195 continue; 5196 } 5197 case CONF_NAMESPACE: 5198 if (allocatedMapFlag) { 5199 Tcl_DecrRefCount(mapObj); 5200 } 5201 Tcl_AppendResult(interp, "option -namespace is read-only", 5202 NULL); 5203 return TCL_ERROR; 5204 case CONF_PREFIX: 5205 if (Tcl_GetBooleanFromObj(interp, objv[1], 5206 &permitPrefix) != TCL_OK) { 5207 if (allocatedMapFlag) { 5208 Tcl_DecrRefCount(mapObj); 5209 } 5210 return TCL_ERROR; 5211 } 5212 continue; 5213 case CONF_UNKNOWN: 5214 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { 5215 if (allocatedMapFlag) { 5216 Tcl_DecrRefCount(mapObj); 5217 } 5218 return TCL_ERROR; 5219 } 5220 unknownObj = (len > 0 ? objv[1] : NULL); 5221 continue; 5222 } 5223 } 5224 5225 /* 5226 * Update the namespace now that we've finished the parsing stage. 5227 */ 5228 5229 flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX 5230 : flags&~TCL_ENSEMBLE_PREFIX); 5231 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); 5232 Tcl_SetEnsembleMappingDict(interp, token, mapObj); 5233 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); 5234 Tcl_SetEnsembleFlags(interp, token, flags); 5235 return TCL_OK; 5236 } 5237 5238 default: 5239 Tcl_Panic("unexpected ensemble command"); 5240 } 5241 return TCL_OK; 5242} 5243 5244/* 5245 *---------------------------------------------------------------------- 5246 * 5247 * Tcl_CreateEnsemble -- 5248 * 5249 * Create a simple ensemble attached to the given namespace. 5250 * 5251 * Results: 5252 * The token for the command created. 5253 * 5254 * Side effects: 5255 * The ensemble is created and marked for compilation. 5256 * 5257 *---------------------------------------------------------------------- 5258 */ 5259 5260Tcl_Command 5261Tcl_CreateEnsemble( 5262 Tcl_Interp *interp, 5263 const char *name, 5264 Tcl_Namespace *namespacePtr, 5265 int flags) 5266{ 5267 Namespace *nsPtr = (Namespace *) namespacePtr; 5268 EnsembleConfig *ensemblePtr = (EnsembleConfig *) 5269 ckalloc(sizeof(EnsembleConfig)); 5270 Tcl_Obj *nameObj = NULL; 5271 5272 if (nsPtr == NULL) { 5273 nsPtr = (Namespace *) TclGetCurrentNamespace(interp); 5274 } 5275 5276 /* 5277 * Make the name of the ensemble into a fully qualified name. This might 5278 * allocate a temporary object. 5279 */ 5280 5281 if (!(name[0] == ':' && name[1] == ':')) { 5282 nameObj = Tcl_NewStringObj(nsPtr->fullName, -1); 5283 if (nsPtr->parentPtr == NULL) { 5284 Tcl_AppendStringsToObj(nameObj, name, NULL); 5285 } else { 5286 Tcl_AppendStringsToObj(nameObj, "::", name, NULL); 5287 } 5288 Tcl_IncrRefCount(nameObj); 5289 name = TclGetString(nameObj); 5290 } 5291 5292 ensemblePtr->nsPtr = nsPtr; 5293 ensemblePtr->epoch = 0; 5294 Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); 5295 ensemblePtr->subcommandArrayPtr = NULL; 5296 ensemblePtr->subcmdList = NULL; 5297 ensemblePtr->subcommandDict = NULL; 5298 ensemblePtr->flags = flags; 5299 ensemblePtr->unknownHandler = NULL; 5300 ensemblePtr->token = Tcl_CreateObjCommand(interp, name, 5301 NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig); 5302 ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; 5303 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; 5304 5305 /* 5306 * Trigger an eventual recomputation of the ensemble command set. Note 5307 * that this is slightly tricky, as it means that we are not actually 5308 * counting the number of namespace export actions, but it is the simplest 5309 * way to go! 5310 */ 5311 5312 nsPtr->exportLookupEpoch++; 5313 5314 if (flags & ENSEMBLE_COMPILE) { 5315 ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; 5316 } 5317 5318 if (nameObj != NULL) { 5319 TclDecrRefCount(nameObj); 5320 } 5321 return ensemblePtr->token; 5322} 5323 5324/* 5325 *---------------------------------------------------------------------- 5326 * 5327 * Tcl_SetEnsembleSubcommandList -- 5328 * 5329 * Set the subcommand list for a particular ensemble. 5330 * 5331 * Results: 5332 * Tcl result code (error if command token does not indicate an ensemble 5333 * or the subcommand list - if non-NULL - is not a list). 5334 * 5335 * Side effects: 5336 * The ensemble is updated and marked for recompilation. 5337 * 5338 *---------------------------------------------------------------------- 5339 */ 5340 5341int 5342Tcl_SetEnsembleSubcommandList( 5343 Tcl_Interp *interp, 5344 Tcl_Command token, 5345 Tcl_Obj *subcmdList) 5346{ 5347 Command *cmdPtr = (Command *) token; 5348 EnsembleConfig *ensemblePtr; 5349 Tcl_Obj *oldList; 5350 5351 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5352 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5353 return TCL_ERROR; 5354 } 5355 if (subcmdList != NULL) { 5356 int length; 5357 5358 if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) { 5359 return TCL_ERROR; 5360 } 5361 if (length < 1) { 5362 subcmdList = NULL; 5363 } 5364 } 5365 5366 ensemblePtr = cmdPtr->objClientData; 5367 oldList = ensemblePtr->subcmdList; 5368 ensemblePtr->subcmdList = subcmdList; 5369 if (subcmdList != NULL) { 5370 Tcl_IncrRefCount(subcmdList); 5371 } 5372 if (oldList != NULL) { 5373 TclDecrRefCount(oldList); 5374 } 5375 5376 /* 5377 * Trigger an eventual recomputation of the ensemble command set. Note 5378 * that this is slightly tricky, as it means that we are not actually 5379 * counting the number of namespace export actions, but it is the simplest 5380 * way to go! 5381 */ 5382 5383 ensemblePtr->nsPtr->exportLookupEpoch++; 5384 5385 /* 5386 * Special hack to make compiling of [info exists] work when the 5387 * dictionary is modified. 5388 */ 5389 5390 if (cmdPtr->compileProc != NULL) { 5391 ((Interp *)interp)->compileEpoch++; 5392 } 5393 5394 return TCL_OK; 5395} 5396 5397/* 5398 *---------------------------------------------------------------------- 5399 * 5400 * Tcl_SetEnsembleMappingDict -- 5401 * 5402 * Set the mapping dictionary for a particular ensemble. 5403 * 5404 * Results: 5405 * Tcl result code (error if command token does not indicate an ensemble 5406 * or the mapping - if non-NULL - is not a dict). 5407 * 5408 * Side effects: 5409 * The ensemble is updated and marked for recompilation. 5410 * 5411 *---------------------------------------------------------------------- 5412 */ 5413 5414int 5415Tcl_SetEnsembleMappingDict( 5416 Tcl_Interp *interp, 5417 Tcl_Command token, 5418 Tcl_Obj *mapDict) 5419{ 5420 Command *cmdPtr = (Command *) token; 5421 EnsembleConfig *ensemblePtr; 5422 Tcl_Obj *oldDict; 5423 5424 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5425 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5426 return TCL_ERROR; 5427 } 5428 if (mapDict != NULL) { 5429 int size, done; 5430 Tcl_DictSearch search; 5431 Tcl_Obj *valuePtr; 5432 5433 if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) { 5434 return TCL_ERROR; 5435 } 5436 5437 for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done); 5438 !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) { 5439 Tcl_Obj *cmdPtr; 5440 const char *bytes; 5441 5442 if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) { 5443 Tcl_DictObjDone(&search); 5444 return TCL_ERROR; 5445 } 5446 bytes = TclGetString(cmdPtr); 5447 if (bytes[0] != ':' || bytes[1] != ':') { 5448 Tcl_AppendResult(interp, 5449 "ensemble target is not a fully-qualified command", 5450 NULL); 5451 Tcl_DictObjDone(&search); 5452 return TCL_ERROR; 5453 } 5454 } 5455 5456 if (size < 1) { 5457 mapDict = NULL; 5458 } 5459 } 5460 5461 ensemblePtr = cmdPtr->objClientData; 5462 oldDict = ensemblePtr->subcommandDict; 5463 ensemblePtr->subcommandDict = mapDict; 5464 if (mapDict != NULL) { 5465 Tcl_IncrRefCount(mapDict); 5466 } 5467 if (oldDict != NULL) { 5468 TclDecrRefCount(oldDict); 5469 } 5470 5471 /* 5472 * Trigger an eventual recomputation of the ensemble command set. Note 5473 * that this is slightly tricky, as it means that we are not actually 5474 * counting the number of namespace export actions, but it is the simplest 5475 * way to go! 5476 */ 5477 5478 ensemblePtr->nsPtr->exportLookupEpoch++; 5479 5480 /* 5481 * Special hack to make compiling of [info exists] work when the 5482 * dictionary is modified. 5483 */ 5484 5485 if (cmdPtr->compileProc != NULL) { 5486 ((Interp *)interp)->compileEpoch++; 5487 } 5488 5489 return TCL_OK; 5490} 5491 5492/* 5493 *---------------------------------------------------------------------- 5494 * 5495 * Tcl_SetEnsembleUnknownHandler -- 5496 * 5497 * Set the unknown handler for a particular ensemble. 5498 * 5499 * Results: 5500 * Tcl result code (error if command token does not indicate an ensemble 5501 * or the unknown handler - if non-NULL - is not a list). 5502 * 5503 * Side effects: 5504 * The ensemble is updated and marked for recompilation. 5505 * 5506 *---------------------------------------------------------------------- 5507 */ 5508 5509int 5510Tcl_SetEnsembleUnknownHandler( 5511 Tcl_Interp *interp, 5512 Tcl_Command token, 5513 Tcl_Obj *unknownList) 5514{ 5515 Command *cmdPtr = (Command *) token; 5516 EnsembleConfig *ensemblePtr; 5517 Tcl_Obj *oldList; 5518 5519 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5520 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5521 return TCL_ERROR; 5522 } 5523 if (unknownList != NULL) { 5524 int length; 5525 5526 if (TclListObjLength(interp, unknownList, &length) != TCL_OK) { 5527 return TCL_ERROR; 5528 } 5529 if (length < 1) { 5530 unknownList = NULL; 5531 } 5532 } 5533 5534 ensemblePtr = cmdPtr->objClientData; 5535 oldList = ensemblePtr->unknownHandler; 5536 ensemblePtr->unknownHandler = unknownList; 5537 if (unknownList != NULL) { 5538 Tcl_IncrRefCount(unknownList); 5539 } 5540 if (oldList != NULL) { 5541 TclDecrRefCount(oldList); 5542 } 5543 5544 /* 5545 * Trigger an eventual recomputation of the ensemble command set. Note 5546 * that this is slightly tricky, as it means that we are not actually 5547 * counting the number of namespace export actions, but it is the simplest 5548 * way to go! 5549 */ 5550 5551 ensemblePtr->nsPtr->exportLookupEpoch++; 5552 5553 return TCL_OK; 5554} 5555 5556/* 5557 *---------------------------------------------------------------------- 5558 * 5559 * Tcl_SetEnsembleFlags -- 5560 * 5561 * Set the flags for a particular ensemble. 5562 * 5563 * Results: 5564 * Tcl result code (error if command token does not indicate an 5565 * ensemble). 5566 * 5567 * Side effects: 5568 * The ensemble is updated and marked for recompilation. 5569 * 5570 *---------------------------------------------------------------------- 5571 */ 5572 5573int 5574Tcl_SetEnsembleFlags( 5575 Tcl_Interp *interp, 5576 Tcl_Command token, 5577 int flags) 5578{ 5579 Command *cmdPtr = (Command *) token; 5580 EnsembleConfig *ensemblePtr; 5581 int wasCompiled; 5582 5583 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5584 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5585 return TCL_ERROR; 5586 } 5587 5588 ensemblePtr = cmdPtr->objClientData; 5589 wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE; 5590 5591 /* 5592 * This API refuses to set the ENS_DEAD flag... 5593 */ 5594 5595 ensemblePtr->flags &= ENS_DEAD; 5596 ensemblePtr->flags |= flags & ~ENS_DEAD; 5597 5598 /* 5599 * Trigger an eventual recomputation of the ensemble command set. Note 5600 * that this is slightly tricky, as it means that we are not actually 5601 * counting the number of namespace export actions, but it is the simplest 5602 * way to go! 5603 */ 5604 5605 ensemblePtr->nsPtr->exportLookupEpoch++; 5606 5607 /* 5608 * If the ENSEMBLE_COMPILE flag status was changed, install or remove the 5609 * compiler function and bump the interpreter's compilation epoch so that 5610 * bytecode gets regenerated. 5611 */ 5612 5613 if (flags & ENSEMBLE_COMPILE) { 5614 if (!wasCompiled) { 5615 ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble; 5616 ((Interp *) interp)->compileEpoch++; 5617 } 5618 } else { 5619 if (wasCompiled) { 5620 ((Command*) ensemblePtr->token)->compileProc = NULL; 5621 ((Interp *) interp)->compileEpoch++; 5622 } 5623 } 5624 5625 return TCL_OK; 5626} 5627 5628/* 5629 *---------------------------------------------------------------------- 5630 * 5631 * Tcl_GetEnsembleSubcommandList -- 5632 * 5633 * Get the list of subcommands associated with a particular ensemble. 5634 * 5635 * Results: 5636 * Tcl result code (error if command token does not indicate an 5637 * ensemble). The list of subcommands is returned by updating the 5638 * variable pointed to by the last parameter (NULL if this is to be 5639 * derived from the mapping dictionary or the associated namespace's 5640 * exported commands). 5641 * 5642 * Side effects: 5643 * None 5644 * 5645 *---------------------------------------------------------------------- 5646 */ 5647 5648int 5649Tcl_GetEnsembleSubcommandList( 5650 Tcl_Interp *interp, 5651 Tcl_Command token, 5652 Tcl_Obj **subcmdListPtr) 5653{ 5654 Command *cmdPtr = (Command *) token; 5655 EnsembleConfig *ensemblePtr; 5656 5657 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5658 if (interp != NULL) { 5659 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5660 } 5661 return TCL_ERROR; 5662 } 5663 5664 ensemblePtr = cmdPtr->objClientData; 5665 *subcmdListPtr = ensemblePtr->subcmdList; 5666 return TCL_OK; 5667} 5668 5669/* 5670 *---------------------------------------------------------------------- 5671 * 5672 * Tcl_GetEnsembleMappingDict -- 5673 * 5674 * Get the command mapping dictionary associated with a particular 5675 * ensemble. 5676 * 5677 * Results: 5678 * Tcl result code (error if command token does not indicate an 5679 * ensemble). The mapping dict is returned by updating the variable 5680 * pointed to by the last parameter (NULL if none is installed). 5681 * 5682 * Side effects: 5683 * None 5684 * 5685 *---------------------------------------------------------------------- 5686 */ 5687 5688int 5689Tcl_GetEnsembleMappingDict( 5690 Tcl_Interp *interp, 5691 Tcl_Command token, 5692 Tcl_Obj **mapDictPtr) 5693{ 5694 Command *cmdPtr = (Command *) token; 5695 EnsembleConfig *ensemblePtr; 5696 5697 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5698 if (interp != NULL) { 5699 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5700 } 5701 return TCL_ERROR; 5702 } 5703 5704 ensemblePtr = cmdPtr->objClientData; 5705 *mapDictPtr = ensemblePtr->subcommandDict; 5706 return TCL_OK; 5707} 5708 5709/* 5710 *---------------------------------------------------------------------- 5711 * 5712 * Tcl_GetEnsembleUnknownHandler -- 5713 * 5714 * Get the unknown handler associated with a particular ensemble. 5715 * 5716 * Results: 5717 * Tcl result code (error if command token does not indicate an 5718 * ensemble). The unknown handler is returned by updating the variable 5719 * pointed to by the last parameter (NULL if no handler is installed). 5720 * 5721 * Side effects: 5722 * None 5723 * 5724 *---------------------------------------------------------------------- 5725 */ 5726 5727int 5728Tcl_GetEnsembleUnknownHandler( 5729 Tcl_Interp *interp, 5730 Tcl_Command token, 5731 Tcl_Obj **unknownListPtr) 5732{ 5733 Command *cmdPtr = (Command *) token; 5734 EnsembleConfig *ensemblePtr; 5735 5736 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5737 if (interp != NULL) { 5738 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5739 } 5740 return TCL_ERROR; 5741 } 5742 5743 ensemblePtr = cmdPtr->objClientData; 5744 *unknownListPtr = ensemblePtr->unknownHandler; 5745 return TCL_OK; 5746} 5747 5748/* 5749 *---------------------------------------------------------------------- 5750 * 5751 * Tcl_GetEnsembleFlags -- 5752 * 5753 * Get the flags for a particular ensemble. 5754 * 5755 * Results: 5756 * Tcl result code (error if command token does not indicate an 5757 * ensemble). The flags are returned by updating the variable pointed to 5758 * by the last parameter. 5759 * 5760 * Side effects: 5761 * None 5762 * 5763 *---------------------------------------------------------------------- 5764 */ 5765 5766int 5767Tcl_GetEnsembleFlags( 5768 Tcl_Interp *interp, 5769 Tcl_Command token, 5770 int *flagsPtr) 5771{ 5772 Command *cmdPtr = (Command *) token; 5773 EnsembleConfig *ensemblePtr; 5774 5775 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5776 if (interp != NULL) { 5777 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5778 } 5779 return TCL_ERROR; 5780 } 5781 5782 ensemblePtr = cmdPtr->objClientData; 5783 *flagsPtr = ensemblePtr->flags; 5784 return TCL_OK; 5785} 5786 5787/* 5788 *---------------------------------------------------------------------- 5789 * 5790 * Tcl_GetEnsembleNamespace -- 5791 * 5792 * Get the namespace associated with a particular ensemble. 5793 * 5794 * Results: 5795 * Tcl result code (error if command token does not indicate an 5796 * ensemble). Namespace is returned by updating the variable pointed to 5797 * by the last parameter. 5798 * 5799 * Side effects: 5800 * None 5801 * 5802 *---------------------------------------------------------------------- 5803 */ 5804 5805int 5806Tcl_GetEnsembleNamespace( 5807 Tcl_Interp *interp, 5808 Tcl_Command token, 5809 Tcl_Namespace **namespacePtrPtr) 5810{ 5811 Command *cmdPtr = (Command *) token; 5812 EnsembleConfig *ensemblePtr; 5813 5814 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5815 if (interp != NULL) { 5816 Tcl_AppendResult(interp, "command is not an ensemble", NULL); 5817 } 5818 return TCL_ERROR; 5819 } 5820 5821 ensemblePtr = cmdPtr->objClientData; 5822 *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr; 5823 return TCL_OK; 5824} 5825 5826/* 5827 *---------------------------------------------------------------------- 5828 * 5829 * Tcl_FindEnsemble -- 5830 * 5831 * Given a command name, get the ensemble token for it, allowing for 5832 * [namespace import]s. [Bug 1017022] 5833 * 5834 * Results: 5835 * The token for the ensemble command with the given name, or NULL if the 5836 * command either does not exist or is not an ensemble (when an error 5837 * message will be written into the interp if thats non-NULL). 5838 * 5839 * Side effects: 5840 * None 5841 * 5842 *---------------------------------------------------------------------- 5843 */ 5844 5845Tcl_Command 5846Tcl_FindEnsemble( 5847 Tcl_Interp *interp, /* Where to do the lookup, and where to write 5848 * the errors if TCL_LEAVE_ERR_MSG is set in 5849 * the flags. */ 5850 Tcl_Obj *cmdNameObj, /* Name of command to look up. */ 5851 int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags 5852 * are probably not useful. */ 5853{ 5854 Command *cmdPtr; 5855 5856 cmdPtr = (Command *) 5857 Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags); 5858 if (cmdPtr == NULL) { 5859 return NULL; 5860 } 5861 5862 if (cmdPtr->objProc != NsEnsembleImplementationCmd) { 5863 /* 5864 * Reuse existing infrastructure for following import link chains 5865 * rather than duplicating it. 5866 */ 5867 5868 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); 5869 5870 if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { 5871 if (flags & TCL_LEAVE_ERR_MSG) { 5872 Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj), 5873 "\" is not an ensemble command", NULL); 5874 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", 5875 TclGetString(cmdNameObj), NULL); 5876 } 5877 return NULL; 5878 } 5879 } 5880 5881 return (Tcl_Command) cmdPtr; 5882} 5883 5884/* 5885 *---------------------------------------------------------------------- 5886 * 5887 * Tcl_IsEnsemble -- 5888 * 5889 * Simple test for ensemble-hood that takes into account imported 5890 * ensemble commands as well. 5891 * 5892 * Results: 5893 * Boolean value 5894 * 5895 * Side effects: 5896 * None 5897 * 5898 *---------------------------------------------------------------------- 5899 */ 5900 5901int 5902Tcl_IsEnsemble( 5903 Tcl_Command token) 5904{ 5905 Command *cmdPtr = (Command *) token; 5906 if (cmdPtr->objProc == NsEnsembleImplementationCmd) { 5907 return 1; 5908 } 5909 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); 5910 if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { 5911 return 0; 5912 } 5913 return 1; 5914} 5915 5916/* 5917 *---------------------------------------------------------------------- 5918 * 5919 * TclMakeEnsemble -- 5920 * 5921 * Create an ensemble from a table of implementation commands. The 5922 * ensemble will be subject to (limited) compilation if any of the 5923 * implementation commands are compilable. 5924 * 5925 * Results: 5926 * Handle for the ensemble, or NULL if creation of it fails. 5927 * 5928 * Side effects: 5929 * May advance bytecode compilation epoch. 5930 * 5931 *---------------------------------------------------------------------- 5932 */ 5933 5934Tcl_Command 5935TclMakeEnsemble( 5936 Tcl_Interp *interp, 5937 const char *name, 5938 const EnsembleImplMap map[]) 5939{ 5940 Tcl_Command ensemble; /* The overall ensemble. */ 5941 Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */ 5942 Tcl_DString buf; 5943 5944 tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL, 5945 TCL_CREATE_NS_IF_UNKNOWN); 5946 if (tclNsPtr == NULL) { 5947 Tcl_Panic("unable to find or create ::tcl namespace!"); 5948 } 5949 Tcl_DStringInit(&buf); 5950 Tcl_DStringAppend(&buf, "::tcl::", -1); 5951 Tcl_DStringAppend(&buf, name, -1); 5952 tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL, 5953 TCL_CREATE_NS_IF_UNKNOWN); 5954 if (tclNsPtr == NULL) { 5955 Tcl_Panic("unable to find or create %s namespace!", 5956 Tcl_DStringValue(&buf)); 5957 } 5958 ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr, 5959 TCL_ENSEMBLE_PREFIX); 5960 Tcl_DStringAppend(&buf, "::", -1); 5961 if (ensemble != NULL) { 5962 Tcl_Obj *mapDict; 5963 int i, compile = 0; 5964 5965 TclNewObj(mapDict); 5966 for (i=0 ; map[i].name != NULL ; i++) { 5967 Tcl_Obj *fromObj, *toObj; 5968 Command *cmdPtr; 5969 5970 fromObj = Tcl_NewStringObj(map[i].name, -1); 5971 TclNewStringObj(toObj, Tcl_DStringValue(&buf), 5972 Tcl_DStringLength(&buf)); 5973 Tcl_AppendToObj(toObj, map[i].name, -1); 5974 Tcl_DictObjPut(NULL, mapDict, fromObj, toObj); 5975 cmdPtr = (Command *) Tcl_CreateObjCommand(interp, 5976 TclGetString(toObj), map[i].proc, NULL, NULL); 5977 cmdPtr->compileProc = map[i].compileProc; 5978 compile |= (map[i].compileProc != NULL); 5979 } 5980 Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict); 5981 if (compile) { 5982 Tcl_SetEnsembleFlags(interp, ensemble, 5983 TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE); 5984 } 5985 } 5986 Tcl_DStringFree(&buf); 5987 5988 return ensemble; 5989} 5990 5991/* 5992 *---------------------------------------------------------------------- 5993 * 5994 * NsEnsembleImplementationCmd -- 5995 * 5996 * Implements an ensemble of commands (being those exported by a 5997 * namespace other than the global namespace) as a command with the same 5998 * (short) name as the namespace in the parent namespace. 5999 * 6000 * Results: 6001 * A standard Tcl result code. Will be TCL_ERROR if the command is not an 6002 * unambiguous prefix of any command exported by the ensemble's 6003 * namespace. 6004 * 6005 * Side effects: 6006 * Depends on the command within the namespace that gets executed. If the 6007 * ensemble itself returns TCL_ERROR, a descriptive error message will be 6008 * placed in the interpreter's result. 6009 * 6010 *---------------------------------------------------------------------- 6011 */ 6012 6013static int 6014NsEnsembleImplementationCmd( 6015 ClientData clientData, 6016 Tcl_Interp *interp, 6017 int objc, 6018 Tcl_Obj *const objv[]) 6019{ 6020 EnsembleConfig *ensemblePtr = clientData; 6021 /* The ensemble itself. */ 6022 Tcl_Obj **tempObjv; /* Space used to construct the list of 6023 * arguments to pass to the command that 6024 * implements the ensemble subcommand. */ 6025 int result; /* The result of the subcommand execution. */ 6026 Tcl_Obj *prefixObj; /* An object containing the prefix words of 6027 * the command that implements the 6028 * subcommand. */ 6029 Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully 6030 * specified but not yet cached command 6031 * names. */ 6032 Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the 6033 * target command prefix. */ 6034 int prefixObjc; /* Size of prefixObjv of course! */ 6035 int reparseCount = 0; /* Number of reparses. */ 6036 6037 if (objc < 2) { 6038 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); 6039 return TCL_ERROR; 6040 } 6041 6042 restartEnsembleParse: 6043 if (ensemblePtr->nsPtr->flags & NS_DYING) { 6044 /* 6045 * Don't know how we got here, but make things give up quickly. 6046 */ 6047 6048 if (!Tcl_InterpDeleted(interp)) { 6049 Tcl_AppendResult(interp, 6050 "ensemble activated for deleted namespace", NULL); 6051 } 6052 return TCL_ERROR; 6053 } 6054 6055 /* 6056 * Determine if the table of subcommands is right. If so, we can just look 6057 * up in there and go straight to dispatch. 6058 */ 6059 6060 if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) { 6061 /* 6062 * Table of subcommands is still valid; therefore there might be a 6063 * valid cache of discovered information which we can reuse. Do the 6064 * check here, and if we're still valid, we can jump straight to the 6065 * part where we do the invocation of the subcommand. 6066 */ 6067 6068 if (objv[1]->typePtr == &tclEnsembleCmdType) { 6069 EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.otherValuePtr; 6070 6071 if (ensembleCmd->nsPtr == ensemblePtr->nsPtr && 6072 ensembleCmd->epoch == ensemblePtr->epoch && 6073 ensembleCmd->token == ensemblePtr->token) { 6074 prefixObj = ensembleCmd->realPrefixObj; 6075 Tcl_IncrRefCount(prefixObj); 6076 goto runResultingSubcommand; 6077 } 6078 } 6079 } else { 6080 BuildEnsembleConfig(ensemblePtr); 6081 ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch; 6082 } 6083 6084 /* 6085 * Look in the hashtable for the subcommand name; this is the fastest way 6086 * of all. 6087 */ 6088 6089 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, 6090 TclGetString(objv[1])); 6091 if (hPtr != NULL) { 6092 char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr); 6093 6094 prefixObj = Tcl_GetHashValue(hPtr); 6095 6096 /* 6097 * Cache for later in the subcommand object. 6098 */ 6099 6100 MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); 6101 } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) { 6102 /* 6103 * Could not map, no prefixing, go to unknown/error handling. 6104 */ 6105 6106 goto unknownOrAmbiguousSubcommand; 6107 } else { 6108 /* 6109 * If we've not already confirmed the command with the hash as part of 6110 * building our export table, we need to scan the sorted array for 6111 * matches. 6112 */ 6113 6114 char *subcmdName; /* Name of the subcommand, or unique prefix of 6115 * it (will be an error for a non-unique 6116 * prefix). */ 6117 char *fullName = NULL; /* Full name of the subcommand. */ 6118 int stringLength, i; 6119 int tableLength = ensemblePtr->subcommandTable.numEntries; 6120 6121 subcmdName = TclGetString(objv[1]); 6122 stringLength = objv[1]->length; 6123 for (i=0 ; i<tableLength ; i++) { 6124 register int cmp = strncmp(subcmdName, 6125 ensemblePtr->subcommandArrayPtr[i], 6126 (unsigned) stringLength); 6127 6128 if (cmp == 0) { 6129 if (fullName != NULL) { 6130 /* 6131 * Since there's never the exact-match case to worry about 6132 * (hash search filters this), getting here indicates that 6133 * our subcommand is an ambiguous prefix of (at least) two 6134 * exported subcommands, which is an error case. 6135 */ 6136 6137 goto unknownOrAmbiguousSubcommand; 6138 } 6139 fullName = ensemblePtr->subcommandArrayPtr[i]; 6140 } else if (cmp < 0) { 6141 /* 6142 * Because we are searching a sorted table, we can now stop 6143 * searching because we have gone past anything that could 6144 * possibly match. 6145 */ 6146 6147 break; 6148 } 6149 } 6150 if (fullName == NULL) { 6151 /* 6152 * The subcommand is not a prefix of anything, so bail out! 6153 */ 6154 6155 goto unknownOrAmbiguousSubcommand; 6156 } 6157 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); 6158 if (hPtr == NULL) { 6159 Tcl_Panic("full name %s not found in supposedly synchronized hash", 6160 fullName); 6161 } 6162 prefixObj = Tcl_GetHashValue(hPtr); 6163 6164 /* 6165 * Cache for later in the subcommand object. 6166 */ 6167 6168 MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj); 6169 } 6170 6171 Tcl_IncrRefCount(prefixObj); 6172 runResultingSubcommand: 6173 6174 /* 6175 * Do the real work of execution of the subcommand by building an array of 6176 * objects (note that this is potentially not the same length as the 6177 * number of arguments to this ensemble command), populating it and then 6178 * feeding it back through the main command-lookup engine. In theory, we 6179 * could look up the command in the namespace ourselves, as we already 6180 * have the namespace in which it is guaranteed to exist, but we don't do 6181 * that (the cacheing of the command object used should help with that.) 6182 */ 6183 6184 { 6185 Interp *iPtr = (Interp *) interp; 6186 int isRootEnsemble; 6187 Tcl_Obj *copyObj; 6188 6189 /* 6190 * Get the prefix that we're rewriting to. To do this we need to 6191 * ensure that the internal representation of the list does not change 6192 * so that we can safely keep the internal representations of the 6193 * elements in the list. 6194 */ 6195 6196 copyObj = TclListObjCopy(NULL, prefixObj); 6197 TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); 6198 6199 /* 6200 * Record what arguments the script sent in so that things like 6201 * Tcl_WrongNumArgs can give the correct error message. 6202 */ 6203 6204 isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); 6205 if (isRootEnsemble) { 6206 iPtr->ensembleRewrite.sourceObjs = objv; 6207 iPtr->ensembleRewrite.numRemovedObjs = 2; 6208 iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; 6209 } else { 6210 int ni = iPtr->ensembleRewrite.numInsertedObjs; 6211 6212 if (ni < 2) { 6213 iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; 6214 iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1; 6215 } else { 6216 iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2; 6217 } 6218 } 6219 6220 /* 6221 * Allocate a workspace and build the list of arguments to pass to the 6222 * target command in it. 6223 */ 6224 6225 tempObjv = (Tcl_Obj **) TclStackAlloc(interp, 6226 (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc)); 6227 memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); 6228 memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); 6229 6230 /* 6231 * Hand off to the target command. 6232 */ 6233 6234 result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv, 6235 TCL_EVAL_INVOKE); 6236 6237 /* 6238 * Clean up. 6239 */ 6240 6241 TclStackFree(interp, tempObjv); 6242 Tcl_DecrRefCount(copyObj); 6243 if (isRootEnsemble) { 6244 iPtr->ensembleRewrite.sourceObjs = NULL; 6245 iPtr->ensembleRewrite.numRemovedObjs = 0; 6246 iPtr->ensembleRewrite.numInsertedObjs = 0; 6247 } 6248 } 6249 Tcl_DecrRefCount(prefixObj); 6250 return result; 6251 6252 unknownOrAmbiguousSubcommand: 6253 /* 6254 * Have not been able to match the subcommand asked for with a real 6255 * subcommand that we export. See whether a handler has been registered 6256 * for dealing with this situation. Will only call (at most) once for any 6257 * particular ensemble invocation. 6258 */ 6259 6260 if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { 6261 int paramc, i; 6262 Tcl_Obj **paramv, *unknownCmd, *ensObj; 6263 6264 unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); 6265 TclNewObj(ensObj); 6266 Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); 6267 Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); 6268 for (i=1 ; i<objc ; i++) { 6269 Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); 6270 } 6271 TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); 6272 Tcl_Preserve(ensemblePtr); 6273 Tcl_IncrRefCount(unknownCmd); 6274 result = Tcl_EvalObjv(interp, paramc, paramv, 0); 6275 if (result == TCL_OK) { 6276 prefixObj = Tcl_GetObjResult(interp); 6277 Tcl_IncrRefCount(prefixObj); 6278 Tcl_DecrRefCount(unknownCmd); 6279 Tcl_Release(ensemblePtr); 6280 Tcl_ResetResult(interp); 6281 if (ensemblePtr->flags & ENS_DEAD) { 6282 Tcl_DecrRefCount(prefixObj); 6283 Tcl_SetResult(interp, 6284 "unknown subcommand handler deleted its ensemble", 6285 TCL_STATIC); 6286 return TCL_ERROR; 6287 } 6288 6289 /* 6290 * Namespace is still there. Check if the result is a valid list. 6291 * If it is, and it is non-empty, that list is what we are using 6292 * as our replacement. 6293 */ 6294 6295 if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { 6296 Tcl_DecrRefCount(prefixObj); 6297 Tcl_AddErrorInfo(interp, "\n while parsing result of " 6298 "ensemble unknown subcommand handler"); 6299 return TCL_ERROR; 6300 } 6301 if (prefixObjc > 0) { 6302 goto runResultingSubcommand; 6303 } 6304 6305 /* 6306 * Namespace alive & empty result => reparse. 6307 */ 6308 6309 Tcl_DecrRefCount(prefixObj); 6310 goto restartEnsembleParse; 6311 } 6312 if (!Tcl_InterpDeleted(interp)) { 6313 if (result != TCL_ERROR) { 6314 char buf[TCL_INTEGER_SPACE]; 6315 6316 Tcl_ResetResult(interp); 6317 Tcl_SetResult(interp, 6318 "unknown subcommand handler returned bad code: ", 6319 TCL_STATIC); 6320 switch (result) { 6321 case TCL_RETURN: 6322 Tcl_AppendResult(interp, "return", NULL); 6323 break; 6324 case TCL_BREAK: 6325 Tcl_AppendResult(interp, "break", NULL); 6326 break; 6327 case TCL_CONTINUE: 6328 Tcl_AppendResult(interp, "continue", NULL); 6329 break; 6330 default: 6331 sprintf(buf, "%d", result); 6332 Tcl_AppendResult(interp, buf, NULL); 6333 } 6334 Tcl_AddErrorInfo(interp, "\n result of " 6335 "ensemble unknown subcommand handler: "); 6336 Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); 6337 } else { 6338 Tcl_AddErrorInfo(interp, 6339 "\n (ensemble unknown subcommand handler)"); 6340 } 6341 } 6342 Tcl_DecrRefCount(unknownCmd); 6343 Tcl_Release(ensemblePtr); 6344 return TCL_ERROR; 6345 } 6346 6347 /* 6348 * We cannot determine what subcommand to hand off to, so generate a 6349 * (standard) failure message. Note the one odd case compared with 6350 * standard ensemble-like command, which is where a namespace has no 6351 * exported commands at all... 6352 */ 6353 6354 Tcl_ResetResult(interp); 6355 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE", 6356 TclGetString(objv[1]), NULL); 6357 if (ensemblePtr->subcommandTable.numEntries == 0) { 6358 Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), 6359 "\": namespace ", ensemblePtr->nsPtr->fullName, 6360 " does not export any commands", NULL); 6361 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", 6362 TclGetString(objv[1]), NULL); 6363 return TCL_ERROR; 6364 } 6365 Tcl_AppendResult(interp, "unknown ", 6366 (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""), 6367 "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL); 6368 if (ensemblePtr->subcommandTable.numEntries == 1) { 6369 Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL); 6370 } else { 6371 int i; 6372 6373 for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) { 6374 Tcl_AppendResult(interp, 6375 ensemblePtr->subcommandArrayPtr[i], ", ", NULL); 6376 } 6377 Tcl_AppendResult(interp, "or ", 6378 ensemblePtr->subcommandArrayPtr[i], NULL); 6379 } 6380 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND", 6381 TclGetString(objv[1]), NULL); 6382 return TCL_ERROR; 6383} 6384 6385/* 6386 *---------------------------------------------------------------------- 6387 * 6388 * MakeCachedEnsembleCommand -- 6389 * 6390 * Cache what we've computed so far; it's not nice to repeatedly copy 6391 * strings about. Note that to do this, we start by deleting any old 6392 * representation that there was (though if it was an out of date 6393 * ensemble rep, we can skip some of the deallocation process.) 6394 * 6395 * Results: 6396 * None 6397 * 6398 * Side effects: 6399 * Alters the internal representation of the first object parameter. 6400 * 6401 *---------------------------------------------------------------------- 6402 */ 6403 6404static void 6405MakeCachedEnsembleCommand( 6406 Tcl_Obj *objPtr, 6407 EnsembleConfig *ensemblePtr, 6408 const char *subcommandName, 6409 Tcl_Obj *prefixObjPtr) 6410{ 6411 register EnsembleCmdRep *ensembleCmd; 6412 int length; 6413 6414 if (objPtr->typePtr == &tclEnsembleCmdType) { 6415 ensembleCmd = objPtr->internalRep.otherValuePtr; 6416 Tcl_DecrRefCount(ensembleCmd->realPrefixObj); 6417 ensembleCmd->nsPtr->refCount--; 6418 if ((ensembleCmd->nsPtr->refCount == 0) 6419 && (ensembleCmd->nsPtr->flags & NS_DEAD)) { 6420 NamespaceFree(ensembleCmd->nsPtr); 6421 } 6422 ckfree(ensembleCmd->fullSubcmdName); 6423 } else { 6424 /* 6425 * Kill the old internal rep, and replace it with a brand new one of 6426 * our own. 6427 */ 6428 6429 TclFreeIntRep(objPtr); 6430 ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); 6431 objPtr->internalRep.otherValuePtr = ensembleCmd; 6432 objPtr->typePtr = &tclEnsembleCmdType; 6433 } 6434 6435 /* 6436 * Populate the internal rep. 6437 */ 6438 6439 ensembleCmd->nsPtr = ensemblePtr->nsPtr; 6440 ensembleCmd->epoch = ensemblePtr->epoch; 6441 ensembleCmd->token = ensemblePtr->token; 6442 ensemblePtr->nsPtr->refCount++; 6443 ensembleCmd->realPrefixObj = prefixObjPtr; 6444 length = strlen(subcommandName)+1; 6445 ensembleCmd->fullSubcmdName = ckalloc((unsigned) length); 6446 memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length); 6447 Tcl_IncrRefCount(ensembleCmd->realPrefixObj); 6448} 6449 6450/* 6451 *---------------------------------------------------------------------- 6452 * 6453 * DeleteEnsembleConfig -- 6454 * 6455 * Destroys the data structure used to represent an ensemble. This is 6456 * called when the ensemble's command is deleted (which happens 6457 * automatically if the ensemble's namespace is deleted.) Maintainers 6458 * should note that ensembles should be deleted by deleting their 6459 * commands. 6460 * 6461 * Results: 6462 * None. 6463 * 6464 * Side effects: 6465 * Memory is (eventually) deallocated. 6466 * 6467 *---------------------------------------------------------------------- 6468 */ 6469 6470static void 6471DeleteEnsembleConfig( 6472 ClientData clientData) 6473{ 6474 EnsembleConfig *ensemblePtr = clientData; 6475 Namespace *nsPtr = ensemblePtr->nsPtr; 6476 Tcl_HashSearch search; 6477 Tcl_HashEntry *hEnt; 6478 6479 /* 6480 * Unlink from the ensemble chain if it has not been marked as having been 6481 * done already. 6482 */ 6483 6484 if (ensemblePtr->next != ensemblePtr) { 6485 EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles; 6486 if (ensPtr == ensemblePtr) { 6487 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; 6488 } else { 6489 while (ensPtr != NULL) { 6490 if (ensPtr->next == ensemblePtr) { 6491 ensPtr->next = ensemblePtr->next; 6492 break; 6493 } 6494 ensPtr = ensPtr->next; 6495 } 6496 } 6497 } 6498 6499 /* 6500 * Mark the namespace as dead so code that uses Tcl_Preserve() can tell 6501 * whether disaster happened anyway. 6502 */ 6503 6504 ensemblePtr->flags |= ENS_DEAD; 6505 6506 /* 6507 * Kill the pointer-containing fields. 6508 */ 6509 6510 if (ensemblePtr->subcommandTable.numEntries != 0) { 6511 ckfree((char *) ensemblePtr->subcommandArrayPtr); 6512 } 6513 hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search); 6514 while (hEnt != NULL) { 6515 Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt); 6516 6517 Tcl_DecrRefCount(prefixObj); 6518 hEnt = Tcl_NextHashEntry(&search); 6519 } 6520 Tcl_DeleteHashTable(&ensemblePtr->subcommandTable); 6521 if (ensemblePtr->subcmdList != NULL) { 6522 Tcl_DecrRefCount(ensemblePtr->subcmdList); 6523 } 6524 if (ensemblePtr->subcommandDict != NULL) { 6525 Tcl_DecrRefCount(ensemblePtr->subcommandDict); 6526 } 6527 if (ensemblePtr->unknownHandler != NULL) { 6528 Tcl_DecrRefCount(ensemblePtr->unknownHandler); 6529 } 6530 6531 /* 6532 * Arrange for the structure to be reclaimed. Note that this is complex 6533 * because we have to make sure that we can react sensibly when an 6534 * ensemble is deleted during the process of initialising the ensemble 6535 * (especially the unknown callback.) 6536 */ 6537 6538 Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC); 6539} 6540 6541/* 6542 *---------------------------------------------------------------------- 6543 * 6544 * BuildEnsembleConfig -- 6545 * 6546 * Create the internal data structures that describe how an ensemble 6547 * looks, being a hash mapping from the full command name to the Tcl list 6548 * that describes the implementation prefix words, and a sorted array of 6549 * all the full command names to allow for reasonably efficient 6550 * unambiguous prefix handling. 6551 * 6552 * Results: 6553 * None. 6554 * 6555 * Side effects: 6556 * Reallocates and rebuilds the hash table and array stored at the 6557 * ensemblePtr argument. For large ensembles or large namespaces, this is 6558 * a potentially expensive operation. 6559 * 6560 *---------------------------------------------------------------------- 6561 */ 6562 6563static void 6564BuildEnsembleConfig( 6565 EnsembleConfig *ensemblePtr) 6566{ 6567 Tcl_HashSearch search; /* Used for scanning the set of commands in 6568 * the namespace that backs up this 6569 * ensemble. */ 6570 int i, j, isNew; 6571 Tcl_HashTable *hash = &ensemblePtr->subcommandTable; 6572 Tcl_HashEntry *hPtr; 6573 6574 if (hash->numEntries != 0) { 6575 /* 6576 * Remove pre-existing table. 6577 */ 6578 6579 Tcl_HashSearch search; 6580 6581 ckfree((char *) ensemblePtr->subcommandArrayPtr); 6582 hPtr = Tcl_FirstHashEntry(hash, &search); 6583 while (hPtr != NULL) { 6584 Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr); 6585 Tcl_DecrRefCount(prefixObj); 6586 hPtr = Tcl_NextHashEntry(&search); 6587 } 6588 Tcl_DeleteHashTable(hash); 6589 Tcl_InitHashTable(hash, TCL_STRING_KEYS); 6590 } 6591 6592 /* 6593 * See if we've got an export list. If so, we will only export exactly 6594 * those commands, which may be either implemented by the prefix in the 6595 * subcommandDict or mapped directly onto the namespace's commands. 6596 */ 6597 6598 if (ensemblePtr->subcmdList != NULL) { 6599 Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj; 6600 int subcmdc; 6601 6602 TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc, 6603 &subcmdv); 6604 for (i=0 ; i<subcmdc ; i++) { 6605 char *name = TclGetString(subcmdv[i]); 6606 6607 hPtr = Tcl_CreateHashEntry(hash, name, &isNew); 6608 6609 /* 6610 * Skip non-unique cases. 6611 */ 6612 6613 if (!isNew) { 6614 continue; 6615 } 6616 6617 /* 6618 * Look in our dictionary (if present) for the command. 6619 */ 6620 6621 if (ensemblePtr->subcommandDict != NULL) { 6622 Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i], 6623 &target); 6624 if (target != NULL) { 6625 Tcl_SetHashValue(hPtr, target); 6626 Tcl_IncrRefCount(target); 6627 continue; 6628 } 6629 } 6630 6631 /* 6632 * Not there, so map onto the namespace. Note in this case that we 6633 * do not guarantee that the command is actually there; that is 6634 * the programmer's responsibility (or [::unknown] of course). 6635 */ 6636 6637 cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1); 6638 if (ensemblePtr->nsPtr->parentPtr != NULL) { 6639 Tcl_AppendStringsToObj(cmdObj, "::", name, NULL); 6640 } else { 6641 Tcl_AppendStringsToObj(cmdObj, name, NULL); 6642 } 6643 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); 6644 Tcl_SetHashValue(hPtr, cmdPrefixObj); 6645 Tcl_IncrRefCount(cmdPrefixObj); 6646 } 6647 } else if (ensemblePtr->subcommandDict != NULL) { 6648 /* 6649 * No subcmd list, but we do have a mapping dictionary so we should 6650 * use the keys of that. Convert the dictionary's contents into the 6651 * form required for the ensemble's internal hashtable. 6652 */ 6653 6654 Tcl_DictSearch dictSearch; 6655 Tcl_Obj *keyObj, *valueObj; 6656 int done; 6657 6658 Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, 6659 &keyObj, &valueObj, &done); 6660 while (!done) { 6661 char *name = TclGetString(keyObj); 6662 6663 hPtr = Tcl_CreateHashEntry(hash, name, &isNew); 6664 Tcl_SetHashValue(hPtr, valueObj); 6665 Tcl_IncrRefCount(valueObj); 6666 Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done); 6667 } 6668 } else { 6669 /* 6670 * Discover what commands are actually exported by the namespace. 6671 * What we have is an array of patterns and a hash table whose keys 6672 * are the command names exported by the namespace (the contents do 6673 * not matter here.) We must find out what commands are actually 6674 * exported by filtering each command in the namespace against each of 6675 * the patterns in the export list. Note that we use an intermediate 6676 * hash table to make memory management easier, and because that makes 6677 * exact matching far easier too. 6678 * 6679 * Suggestion for future enhancement: compute the unique prefixes and 6680 * place them in the hash too, which should make for even faster 6681 * matching. 6682 */ 6683 6684 hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); 6685 for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { 6686 char *nsCmdName = /* Name of command in namespace. */ 6687 Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); 6688 6689 for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) { 6690 if (Tcl_StringMatch(nsCmdName, 6691 ensemblePtr->nsPtr->exportArrayPtr[i])) { 6692 hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); 6693 6694 /* 6695 * Remember, hash entries have a full reference to the 6696 * substituted part of the command (as a list) as their 6697 * content! 6698 */ 6699 6700 if (isNew) { 6701 Tcl_Obj *cmdObj, *cmdPrefixObj; 6702 6703 TclNewObj(cmdObj); 6704 Tcl_AppendStringsToObj(cmdObj, 6705 ensemblePtr->nsPtr->fullName, 6706 (ensemblePtr->nsPtr->parentPtr ? "::" : ""), 6707 nsCmdName, NULL); 6708 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); 6709 Tcl_SetHashValue(hPtr, cmdPrefixObj); 6710 Tcl_IncrRefCount(cmdPrefixObj); 6711 } 6712 break; 6713 } 6714 } 6715 } 6716 } 6717 6718 if (hash->numEntries == 0) { 6719 ensemblePtr->subcommandArrayPtr = NULL; 6720 return; 6721 } 6722 6723 /* 6724 * Create a sorted array of all subcommands in the ensemble; hash tables 6725 * are all very well for a quick look for an exact match, but they can't 6726 * determine things like whether a string is a prefix of another (not 6727 * without lots of preparation anyway) and they're no good for when we're 6728 * generating the error message either. 6729 * 6730 * We do this by filling an array with the names (we use the hash keys 6731 * directly to save a copy, since any time we change the array we change 6732 * the hash too, and vice versa) and running quicksort over the array. 6733 */ 6734 6735 ensemblePtr->subcommandArrayPtr = (char **) 6736 ckalloc(sizeof(char *) * hash->numEntries); 6737 6738 /* 6739 * Fill array from both ends as this makes us less likely to end up with 6740 * performance problems in qsort(), which is good. Note that doing this 6741 * makes this code much more opaque, but the naive alternatve: 6742 * 6743 * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ; 6744 * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) { 6745 * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr); 6746 * } 6747 * 6748 * can produce long runs of precisely ordered table entries when the 6749 * commands in the namespace are declared in a sorted fashion (an ordering 6750 * some people like) and the hashing functions (or the command names 6751 * themselves) are fairly unfortunate. By filling from both ends, it 6752 * requires active malice (and probably a debugger) to get qsort() to have 6753 * awful runtime behaviour. 6754 */ 6755 6756 i = 0; 6757 j = hash->numEntries; 6758 hPtr = Tcl_FirstHashEntry(hash, &search); 6759 while (hPtr != NULL) { 6760 ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr); 6761 hPtr = Tcl_NextHashEntry(&search); 6762 if (hPtr == NULL) { 6763 break; 6764 } 6765 ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr); 6766 hPtr = Tcl_NextHashEntry(&search); 6767 } 6768 if (hash->numEntries > 1) { 6769 qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries, 6770 sizeof(char *), NsEnsembleStringOrder); 6771 } 6772} 6773 6774/* 6775 *---------------------------------------------------------------------- 6776 * 6777 * NsEnsembleStringOrder -- 6778 * 6779 * Helper function to compare two pointers to two strings for use with 6780 * qsort(). 6781 * 6782 * Results: 6783 * -1 if the first string is smaller, 1 if the second string is smaller, 6784 * and 0 if they are equal. 6785 * 6786 * Side effects: 6787 * None. 6788 * 6789 *---------------------------------------------------------------------- 6790 */ 6791 6792static int 6793NsEnsembleStringOrder( 6794 const void *strPtr1, 6795 const void *strPtr2) 6796{ 6797 return strcmp(*(const char **)strPtr1, *(const char **)strPtr2); 6798} 6799 6800/* 6801 *---------------------------------------------------------------------- 6802 * 6803 * FreeEnsembleCmdRep -- 6804 * 6805 * Destroys the internal representation of a Tcl_Obj that has been 6806 * holding information about a command in an ensemble. 6807 * 6808 * Results: 6809 * None. 6810 * 6811 * Side effects: 6812 * Memory is deallocated. If this held the last reference to a 6813 * namespace's main structure, that main structure will also be 6814 * destroyed. 6815 * 6816 *---------------------------------------------------------------------- 6817 */ 6818 6819static void 6820FreeEnsembleCmdRep( 6821 Tcl_Obj *objPtr) 6822{ 6823 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; 6824 6825 Tcl_DecrRefCount(ensembleCmd->realPrefixObj); 6826 ckfree(ensembleCmd->fullSubcmdName); 6827 ensembleCmd->nsPtr->refCount--; 6828 if ((ensembleCmd->nsPtr->refCount == 0) 6829 && (ensembleCmd->nsPtr->flags & NS_DEAD)) { 6830 NamespaceFree(ensembleCmd->nsPtr); 6831 } 6832 ckfree((char *) ensembleCmd); 6833} 6834 6835/* 6836 *---------------------------------------------------------------------- 6837 * 6838 * DupEnsembleCmdRep -- 6839 * 6840 * Makes one Tcl_Obj into a copy of another that is a subcommand of an 6841 * ensemble. 6842 * 6843 * Results: 6844 * None. 6845 * 6846 * Side effects: 6847 * Memory is allocated, and the namespace that the ensemble is built on 6848 * top of gains another reference. 6849 * 6850 *---------------------------------------------------------------------- 6851 */ 6852 6853static void 6854DupEnsembleCmdRep( 6855 Tcl_Obj *objPtr, 6856 Tcl_Obj *copyPtr) 6857{ 6858 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; 6859 EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *) 6860 ckalloc(sizeof(EnsembleCmdRep)); 6861 int length = strlen(ensembleCmd->fullSubcmdName); 6862 6863 copyPtr->typePtr = &tclEnsembleCmdType; 6864 copyPtr->internalRep.otherValuePtr = ensembleCopy; 6865 ensembleCopy->nsPtr = ensembleCmd->nsPtr; 6866 ensembleCopy->epoch = ensembleCmd->epoch; 6867 ensembleCopy->token = ensembleCmd->token; 6868 ensembleCopy->nsPtr->refCount++; 6869 ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj; 6870 Tcl_IncrRefCount(ensembleCopy->realPrefixObj); 6871 ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1); 6872 memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName, 6873 (unsigned) length+1); 6874} 6875 6876/* 6877 *---------------------------------------------------------------------- 6878 * 6879 * StringOfEnsembleCmdRep -- 6880 * 6881 * Creates a string representation of a Tcl_Obj that holds a subcommand 6882 * of an ensemble. 6883 * 6884 * Results: 6885 * None. 6886 * 6887 * Side effects: 6888 * The object gains a string (UTF-8) representation. 6889 * 6890 *---------------------------------------------------------------------- 6891 */ 6892 6893static void 6894StringOfEnsembleCmdRep( 6895 Tcl_Obj *objPtr) 6896{ 6897 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr; 6898 int length = strlen(ensembleCmd->fullSubcmdName); 6899 6900 objPtr->length = length; 6901 objPtr->bytes = ckalloc((unsigned) length+1); 6902 memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); 6903} 6904 6905/* 6906 *---------------------------------------------------------------------- 6907 * 6908 * Tcl_LogCommandInfo -- 6909 * 6910 * This function is invoked after an error occurs in an interpreter. It 6911 * adds information to iPtr->errorInfo field to describe the command that 6912 * was being executed when the error occurred. 6913 * 6914 * Results: 6915 * None. 6916 * 6917 * Side effects: 6918 * Information about the command is added to errorInfo and the line 6919 * number stored internally in the interpreter is set. 6920 * 6921 *---------------------------------------------------------------------- 6922 */ 6923 6924void 6925Tcl_LogCommandInfo( 6926 Tcl_Interp *interp, /* Interpreter in which to log information. */ 6927 const char *script, /* First character in script containing 6928 * command (must be <= command). */ 6929 const char *command, /* First character in command that generated 6930 * the error. */ 6931 int length) /* Number of bytes in command (-1 means use 6932 * all bytes up to first null byte). */ 6933{ 6934 register const char *p; 6935 Interp *iPtr = (Interp *) interp; 6936 int overflow, limit = 150; 6937 Var *varPtr, *arrayPtr; 6938 6939 if (iPtr->flags & ERR_ALREADY_LOGGED) { 6940 /* 6941 * Someone else has already logged error information for this command; 6942 * we shouldn't add anything more. 6943 */ 6944 6945 return; 6946 } 6947 6948 /* 6949 * Compute the line number where the error occurred. 6950 */ 6951 6952 iPtr->errorLine = 1; 6953 for (p = script; p != command; p++) { 6954 if (*p == '\n') { 6955 iPtr->errorLine++; 6956 } 6957 } 6958 6959 if (length < 0) { 6960 length = strlen(command); 6961 } 6962 overflow = (length > limit); 6963 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 6964 "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) 6965 ? "while executing" : "invoked from within"), 6966 (overflow ? limit : length), command, (overflow ? "..." : ""))); 6967 6968 varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, 6969 NULL, 0, 0, &arrayPtr); 6970 if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) { 6971 /* 6972 * Should not happen. 6973 */ 6974 6975 return; 6976 } else { 6977 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces, 6978 (char *) varPtr); 6979 VarTrace *tracePtr = Tcl_GetHashValue(hPtr); 6980 6981 if (tracePtr->traceProc != EstablishErrorInfoTraces) { 6982 /* 6983 * The most recent trace set on ::errorInfo is not the one the 6984 * core itself puts on last. This means some other code is tracing 6985 * the variable, and the additional trace(s) might be write traces 6986 * that expect the timing of writes to ::errorInfo that existed 6987 * Tcl releases before 8.5. To satisfy that compatibility need, we 6988 * write the current -errorinfo value to the ::errorInfo variable. 6989 */ 6990 6991 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo, 6992 TCL_GLOBAL_ONLY); 6993 } 6994 } 6995} 6996 6997/* 6998 * Local Variables: 6999 * mode: c 7000 * c-basic-offset: 4 7001 * fill-column: 78 7002 * End: 7003 */ 7004