1/* 2 * tclNamesp.c -- 3 * 4 * Contains support for namespaces, which provide a separate context of 5 * commands and global variables. The global :: namespace is the 6 * traditional Tcl "global" scope. Other namespaces are created as 7 * children of the global namespace. These other namespaces contain 8 * special-purpose commands and variables for packages. 9 * 10 * Copyright (c) 1993-1997 Lucent Technologies. 11 * Copyright (c) 1997 Sun Microsystems, Inc. 12 * Copyright (c) 1998-1999 by Scriptics Corporation. 13 * 14 * Originally implemented by 15 * Michael J. McLennan 16 * Bell Labs Innovations for Lucent Technologies 17 * mmclennan@lucent.com 18 * 19 * See the file "license.terms" for information on usage and redistribution 20 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 21 * 22 * RCS: @(#) $Id: tclNamesp.c,v 1.31.2.14 2007/05/15 18:32:18 dgp Exp $ 23 */ 24 25#include "tclInt.h" 26 27/* 28 * Flag passed to TclGetNamespaceForQualName to indicate that it should 29 * search for a namespace rather than a command or variable inside a 30 * namespace. Note that this flag's value must not conflict with the values 31 * of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, or CREATE_NS_IF_UNKNOWN. 32 */ 33 34#define FIND_ONLY_NS 0x1000 35 36/* 37 * Initial size of stack allocated space for tail list - used when resetting 38 * shadowed command references in the functin: TclResetShadowedCmdRefs. 39 */ 40 41#define NUM_TRAIL_ELEMS 5 42 43/* 44 * Count of the number of namespaces created. This value is used as a 45 * unique id for each namespace. 46 */ 47 48static long numNsCreated = 0; 49TCL_DECLARE_MUTEX(nsMutex) 50 51/* 52 * This structure contains a cached pointer to a namespace that is the 53 * result of resolving the namespace's name in some other namespace. It is 54 * the internal representation for a nsName object. It contains the 55 * pointer along with some information that is used to check the cached 56 * pointer's validity. 57 */ 58 59typedef struct ResolvedNsName { 60 Namespace *nsPtr; /* A cached namespace pointer. */ 61 long nsId; /* nsPtr's unique namespace id. Used to 62 * verify that nsPtr is still valid 63 * (e.g., it's possible that the namespace 64 * was deleted and a new one created at 65 * the same address). */ 66 Namespace *refNsPtr; /* Points to the namespace containing the 67 * reference (not the namespace that 68 * contains the referenced namespace). */ 69 int refCount; /* Reference count: 1 for each nsName 70 * object that has a pointer to this 71 * ResolvedNsName structure as its internal 72 * rep. This structure can be freed when 73 * refCount becomes zero. */ 74} ResolvedNsName; 75 76/* 77 * Declarations for procedures local to this file: 78 */ 79 80static void DeleteImportedCmd _ANSI_ARGS_(( 81 ClientData clientData)); 82static void DupNsNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, 83 Tcl_Obj *copyPtr)); 84static void FreeNsNameInternalRep _ANSI_ARGS_(( 85 Tcl_Obj *objPtr)); 86static int GetNamespaceFromObj _ANSI_ARGS_(( 87 Tcl_Interp *interp, Tcl_Obj *objPtr, 88 Tcl_Namespace **nsPtrPtr)); 89static int InvokeImportedCmd _ANSI_ARGS_(( 90 ClientData clientData, Tcl_Interp *interp, 91 int objc, Tcl_Obj *CONST objv[])); 92static int NamespaceChildrenCmd _ANSI_ARGS_(( 93 ClientData dummy, Tcl_Interp *interp, 94 int objc, Tcl_Obj *CONST objv[])); 95static int NamespaceCodeCmd _ANSI_ARGS_(( 96 ClientData dummy, Tcl_Interp *interp, 97 int objc, Tcl_Obj *CONST objv[])); 98static int NamespaceCurrentCmd _ANSI_ARGS_(( 99 ClientData dummy, Tcl_Interp *interp, 100 int objc, Tcl_Obj *CONST objv[])); 101static int NamespaceDeleteCmd _ANSI_ARGS_(( 102 ClientData dummy, Tcl_Interp *interp, 103 int objc, Tcl_Obj *CONST objv[])); 104static int NamespaceEvalCmd _ANSI_ARGS_(( 105 ClientData dummy, Tcl_Interp *interp, 106 int objc, Tcl_Obj *CONST objv[])); 107static int NamespaceExistsCmd _ANSI_ARGS_(( 108 ClientData dummy, Tcl_Interp *interp, 109 int objc, Tcl_Obj *CONST objv[])); 110static int NamespaceExportCmd _ANSI_ARGS_(( 111 ClientData dummy, Tcl_Interp *interp, 112 int objc, Tcl_Obj *CONST objv[])); 113static int NamespaceForgetCmd _ANSI_ARGS_(( 114 ClientData dummy, Tcl_Interp *interp, 115 int objc, Tcl_Obj *CONST objv[])); 116static void NamespaceFree _ANSI_ARGS_((Namespace *nsPtr)); 117static int NamespaceImportCmd _ANSI_ARGS_(( 118 ClientData dummy, Tcl_Interp *interp, 119 int objc, Tcl_Obj *CONST objv[])); 120static int NamespaceInscopeCmd _ANSI_ARGS_(( 121 ClientData dummy, Tcl_Interp *interp, 122 int objc, Tcl_Obj *CONST objv[])); 123static int NamespaceOriginCmd _ANSI_ARGS_(( 124 ClientData dummy, Tcl_Interp *interp, 125 int objc, Tcl_Obj *CONST objv[])); 126static int NamespaceParentCmd _ANSI_ARGS_(( 127 ClientData dummy, Tcl_Interp *interp, 128 int objc, Tcl_Obj *CONST objv[])); 129static int NamespaceQualifiersCmd _ANSI_ARGS_(( 130 ClientData dummy, Tcl_Interp *interp, 131 int objc, Tcl_Obj *CONST objv[])); 132static int NamespaceTailCmd _ANSI_ARGS_(( 133 ClientData dummy, Tcl_Interp *interp, 134 int objc, Tcl_Obj *CONST objv[])); 135static int NamespaceWhichCmd _ANSI_ARGS_(( 136 ClientData dummy, Tcl_Interp *interp, 137 int objc, Tcl_Obj *CONST objv[])); 138static int SetNsNameFromAny _ANSI_ARGS_(( 139 Tcl_Interp *interp, Tcl_Obj *objPtr)); 140static void UpdateStringOfNsName _ANSI_ARGS_((Tcl_Obj *objPtr)); 141 142/* 143 * This structure defines a Tcl object type that contains a 144 * namespace reference. It is used in commands that take the 145 * name of a namespace as an argument. The namespace reference 146 * is resolved, and the result in cached in the object. 147 */ 148 149Tcl_ObjType tclNsNameType = { 150 "nsName", /* the type's name */ 151 FreeNsNameInternalRep, /* freeIntRepProc */ 152 DupNsNameInternalRep, /* dupIntRepProc */ 153 UpdateStringOfNsName, /* updateStringProc */ 154 SetNsNameFromAny /* setFromAnyProc */ 155}; 156 157/* 158 *---------------------------------------------------------------------- 159 * 160 * TclInitNamespaceSubsystem -- 161 * 162 * This procedure is called to initialize all the structures that 163 * are used by namespaces on a per-process basis. 164 * 165 * Results: 166 * None. 167 * 168 * Side effects: 169 * None. 170 * 171 *---------------------------------------------------------------------- 172 */ 173 174void 175TclInitNamespaceSubsystem() 176{ 177 /* 178 * Does nothing for now. 179 */ 180} 181 182/* 183 *---------------------------------------------------------------------- 184 * 185 * Tcl_GetCurrentNamespace -- 186 * 187 * Returns a pointer to an interpreter's currently active namespace. 188 * 189 * Results: 190 * Returns a pointer to the interpreter's current namespace. 191 * 192 * Side effects: 193 * None. 194 * 195 *---------------------------------------------------------------------- 196 */ 197 198Tcl_Namespace * 199Tcl_GetCurrentNamespace(interp) 200 register Tcl_Interp *interp; /* Interpreter whose current namespace is 201 * being queried. */ 202{ 203 register Interp *iPtr = (Interp *) interp; 204 register Namespace *nsPtr; 205 206 if (iPtr->varFramePtr != NULL) { 207 nsPtr = iPtr->varFramePtr->nsPtr; 208 } else { 209 nsPtr = iPtr->globalNsPtr; 210 } 211 return (Tcl_Namespace *) nsPtr; 212} 213 214/* 215 *---------------------------------------------------------------------- 216 * 217 * Tcl_GetGlobalNamespace -- 218 * 219 * Returns a pointer to an interpreter's global :: namespace. 220 * 221 * Results: 222 * Returns a pointer to the specified interpreter's global namespace. 223 * 224 * Side effects: 225 * None. 226 * 227 *---------------------------------------------------------------------- 228 */ 229 230Tcl_Namespace * 231Tcl_GetGlobalNamespace(interp) 232 register Tcl_Interp *interp; /* Interpreter whose global namespace 233 * should be returned. */ 234{ 235 register Interp *iPtr = (Interp *) interp; 236 237 return (Tcl_Namespace *) iPtr->globalNsPtr; 238} 239 240/* 241 *---------------------------------------------------------------------- 242 * 243 * Tcl_PushCallFrame -- 244 * 245 * Pushes a new call frame onto the interpreter's Tcl call stack. 246 * Called when executing a Tcl procedure or a "namespace eval" or 247 * "namespace inscope" command. 248 * 249 * Results: 250 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 251 * message in the interpreter's result object) if something goes wrong. 252 * 253 * Side effects: 254 * Modifies the interpreter's Tcl call stack. 255 * 256 *---------------------------------------------------------------------- 257 */ 258 259int 260Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) 261 Tcl_Interp *interp; /* Interpreter in which the new call frame 262 * is to be pushed. */ 263 Tcl_CallFrame *callFramePtr; /* Points to a call frame structure to 264 * push. Storage for this has already been 265 * allocated by the caller; typically this 266 * is the address of a CallFrame structure 267 * allocated on the caller's C stack. The 268 * call frame will be initialized by this 269 * procedure. The caller can pop the frame 270 * later with Tcl_PopCallFrame, and it is 271 * responsible for freeing the frame's 272 * storage. */ 273 Tcl_Namespace *namespacePtr; /* Points to the namespace in which the 274 * frame will execute. If NULL, the 275 * interpreter's current namespace will 276 * be used. */ 277 int isProcCallFrame; /* If nonzero, the frame represents a 278 * called Tcl procedure and may have local 279 * vars. Vars will ordinarily be looked up 280 * in the frame. If new variables are 281 * created, they will be created in the 282 * frame. If 0, the frame is for a 283 * "namespace eval" or "namespace inscope" 284 * command and var references are treated 285 * as references to namespace variables. */ 286{ 287 Interp *iPtr = (Interp *) interp; 288 register CallFrame *framePtr = (CallFrame *) callFramePtr; 289 register Namespace *nsPtr; 290 291 if (namespacePtr == NULL) { 292 nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 293 } else { 294 nsPtr = (Namespace *) namespacePtr; 295 if (nsPtr->flags & NS_DEAD) { 296 panic("Trying to push call frame for dead namespace"); 297 /*NOTREACHED*/ 298 } 299 } 300 301 nsPtr->activationCount++; 302 framePtr->nsPtr = nsPtr; 303 framePtr->isProcCallFrame = isProcCallFrame; 304 framePtr->objc = 0; 305 framePtr->objv = NULL; 306 framePtr->callerPtr = iPtr->framePtr; 307 framePtr->callerVarPtr = iPtr->varFramePtr; 308 if (iPtr->varFramePtr != NULL) { 309 framePtr->level = (iPtr->varFramePtr->level + 1); 310 } else { 311 framePtr->level = 1; 312 } 313 framePtr->procPtr = NULL; /* no called procedure */ 314 framePtr->varTablePtr = NULL; /* and no local variables */ 315 framePtr->numCompiledLocals = 0; 316 framePtr->compiledLocals = NULL; 317 318 /* 319 * Push the new call frame onto the interpreter's stack of procedure 320 * call frames making it the current frame. 321 */ 322 323 iPtr->framePtr = framePtr; 324 iPtr->varFramePtr = framePtr; 325 return TCL_OK; 326} 327 328/* 329 *---------------------------------------------------------------------- 330 * 331 * Tcl_PopCallFrame -- 332 * 333 * Removes a call frame from the Tcl call stack for the interpreter. 334 * Called to remove a frame previously pushed by Tcl_PushCallFrame. 335 * 336 * Results: 337 * None. 338 * 339 * Side effects: 340 * Modifies the call stack of the interpreter. Resets various fields of 341 * the popped call frame. If a namespace has been deleted and 342 * has no more activations on the call stack, the namespace is 343 * destroyed. 344 * 345 *---------------------------------------------------------------------- 346 */ 347 348void 349Tcl_PopCallFrame(interp) 350 Tcl_Interp* interp; /* Interpreter with call frame to pop. */ 351{ 352 register Interp *iPtr = (Interp *) interp; 353 register CallFrame *framePtr = iPtr->framePtr; 354 Namespace *nsPtr; 355 356 /* 357 * It's important to remove the call frame from the interpreter's stack 358 * of call frames before deleting local variables, so that traces 359 * invoked by the variable deletion don't see the partially-deleted 360 * frame. 361 */ 362 363 iPtr->framePtr = framePtr->callerPtr; 364 iPtr->varFramePtr = framePtr->callerVarPtr; 365 366 if (framePtr->varTablePtr != NULL) { 367 TclDeleteVars(iPtr, framePtr->varTablePtr); 368 ckfree((char *) framePtr->varTablePtr); 369 framePtr->varTablePtr = NULL; 370 } 371 if (framePtr->numCompiledLocals > 0) { 372 TclDeleteCompiledLocalVars(iPtr, framePtr); 373 } 374 375 /* 376 * Decrement the namespace's count of active call frames. If the 377 * namespace is "dying" and there are no more active call frames, 378 * call Tcl_DeleteNamespace to destroy it. 379 */ 380 381 nsPtr = framePtr->nsPtr; 382 nsPtr->activationCount--; 383 if ((nsPtr->flags & NS_DYING) 384 && (nsPtr->activationCount == 0)) { 385 Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr); 386 } 387 framePtr->nsPtr = NULL; 388} 389 390/* 391 *---------------------------------------------------------------------- 392 * 393 * Tcl_CreateNamespace -- 394 * 395 * Creates a new namespace with the given name. If there is no 396 * active namespace (i.e., the interpreter is being initialized), 397 * the global :: namespace is created and returned. 398 * 399 * Results: 400 * Returns a pointer to the new namespace if successful. If the 401 * namespace already exists or if another error occurs, this routine 402 * returns NULL, along with an error message in the interpreter's 403 * result object. 404 * 405 * Side effects: 406 * If the name contains "::" qualifiers and a parent namespace does 407 * not already exist, it is automatically created. 408 * 409 *---------------------------------------------------------------------- 410 */ 411 412Tcl_Namespace * 413Tcl_CreateNamespace(interp, name, clientData, deleteProc) 414 Tcl_Interp *interp; /* Interpreter in which a new namespace 415 * is being created. Also used for 416 * error reporting. */ 417 CONST char *name; /* Name for the new namespace. May be a 418 * qualified name with names of ancestor 419 * namespaces separated by "::"s. */ 420 ClientData clientData; /* One-word value to store with 421 * namespace. */ 422 Tcl_NamespaceDeleteProc *deleteProc; 423 /* Procedure called to delete client 424 * data when the namespace is deleted. 425 * NULL if no procedure should be 426 * called. */ 427{ 428 Interp *iPtr = (Interp *) interp; 429 register Namespace *nsPtr, *ancestorPtr; 430 Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr; 431 Namespace *globalNsPtr = iPtr->globalNsPtr; 432 CONST char *simpleName; 433 Tcl_HashEntry *entryPtr; 434 Tcl_DString buffer1, buffer2; 435 int newEntry; 436 437 /* 438 * If there is no active namespace, the interpreter is being 439 * initialized. 440 */ 441 442 if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) { 443 /* 444 * Treat this namespace as the global namespace, and avoid 445 * looking for a parent. 446 */ 447 448 parentPtr = NULL; 449 simpleName = ""; 450 } else if (*name == '\0') { 451 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 452 "can't create namespace \"\": only global namespace can have empty name", (char *) NULL); 453 return NULL; 454 } else { 455 /* 456 * Find the parent for the new namespace. 457 */ 458 459 TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, 460 /*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG), 461 &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName); 462 463 /* 464 * If the unqualified name at the end is empty, there were trailing 465 * "::"s after the namespace's name which we ignore. The new 466 * namespace was already (recursively) created and is pointed to 467 * by parentPtr. 468 */ 469 470 if (*simpleName == '\0') { 471 return (Tcl_Namespace *) parentPtr; 472 } 473 474 /* 475 * Check for a bad namespace name and make sure that the name 476 * does not already exist in the parent namespace. 477 */ 478 479 if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { 480 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 481 "can't create namespace \"", name, 482 "\": already exists", (char *) NULL); 483 return NULL; 484 } 485 } 486 487 /* 488 * Create the new namespace and root it in its parent. Increment the 489 * count of namespaces created. 490 */ 491 492 493 nsPtr = (Namespace *) ckalloc(sizeof(Namespace)); 494 nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1)); 495 strcpy(nsPtr->name, simpleName); 496 nsPtr->fullName = NULL; /* set below */ 497 nsPtr->clientData = clientData; 498 nsPtr->deleteProc = deleteProc; 499 nsPtr->parentPtr = parentPtr; 500 Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS); 501 Tcl_MutexLock(&nsMutex); 502 numNsCreated++; 503 nsPtr->nsId = numNsCreated; 504 Tcl_MutexUnlock(&nsMutex); 505 nsPtr->interp = interp; 506 nsPtr->flags = 0; 507 nsPtr->activationCount = 0; 508 nsPtr->refCount = 0; 509 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); 510 Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); 511 nsPtr->exportArrayPtr = NULL; 512 nsPtr->numExportPatterns = 0; 513 nsPtr->maxExportPatterns = 0; 514 nsPtr->cmdRefEpoch = 0; 515 nsPtr->resolverEpoch = 0; 516 nsPtr->cmdResProc = NULL; 517 nsPtr->varResProc = NULL; 518 nsPtr->compiledVarResProc = NULL; 519 520 if (parentPtr != NULL) { 521 entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName, 522 &newEntry); 523 Tcl_SetHashValue(entryPtr, (ClientData) nsPtr); 524 } 525 526 /* 527 * Build the fully qualified name for this namespace. 528 */ 529 530 Tcl_DStringInit(&buffer1); 531 Tcl_DStringInit(&buffer2); 532 for (ancestorPtr = nsPtr; ancestorPtr != NULL; 533 ancestorPtr = ancestorPtr->parentPtr) { 534 if (ancestorPtr != globalNsPtr) { 535 Tcl_DStringAppend(&buffer1, "::", 2); 536 Tcl_DStringAppend(&buffer1, ancestorPtr->name, -1); 537 } 538 Tcl_DStringAppend(&buffer1, Tcl_DStringValue(&buffer2), -1); 539 540 Tcl_DStringSetLength(&buffer2, 0); 541 Tcl_DStringAppend(&buffer2, Tcl_DStringValue(&buffer1), -1); 542 Tcl_DStringSetLength(&buffer1, 0); 543 } 544 545 name = Tcl_DStringValue(&buffer2); 546 nsPtr->fullName = (char *) ckalloc((unsigned) (strlen(name)+1)); 547 strcpy(nsPtr->fullName, name); 548 549 Tcl_DStringFree(&buffer1); 550 Tcl_DStringFree(&buffer2); 551 552 /* 553 * Return a pointer to the new namespace. 554 */ 555 556 return (Tcl_Namespace *) nsPtr; 557} 558 559/* 560 *---------------------------------------------------------------------- 561 * 562 * Tcl_DeleteNamespace -- 563 * 564 * Deletes a namespace and all of the commands, variables, and other 565 * namespaces within it. 566 * 567 * Results: 568 * None. 569 * 570 * Side effects: 571 * When a namespace is deleted, it is automatically removed as a 572 * child of its parent namespace. Also, all its commands, variables 573 * and child namespaces are deleted. 574 * 575 *---------------------------------------------------------------------- 576 */ 577 578void 579Tcl_DeleteNamespace(namespacePtr) 580 Tcl_Namespace *namespacePtr; /* Points to the namespace to delete. */ 581{ 582 register Namespace *nsPtr = (Namespace *) namespacePtr; 583 Interp *iPtr = (Interp *) nsPtr->interp; 584 Namespace *globalNsPtr = 585 (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); 586 Tcl_HashEntry *entryPtr; 587 588 /* 589 * If the namespace is on the call frame stack, it is marked as "dying" 590 * (NS_DYING is OR'd into its flags): the namespace can't be looked up 591 * by name but its commands and variables are still usable by those 592 * active call frames. When all active call frames referring to the 593 * namespace have been popped from the Tcl stack, Tcl_PopCallFrame will 594 * call this procedure again to delete everything in the namespace. 595 * If no nsName objects refer to the namespace (i.e., if its refCount 596 * is zero), its commands and variables are deleted and the storage for 597 * its namespace structure is freed. Otherwise, if its refCount is 598 * nonzero, the namespace's commands and variables are deleted but the 599 * structure isn't freed. Instead, NS_DEAD is OR'd into the structure's 600 * flags to allow the namespace resolution code to recognize that the 601 * namespace is "deleted". The structure's storage is freed by 602 * FreeNsNameInternalRep when its refCount reaches 0. 603 */ 604 605 if (nsPtr->activationCount > 0) { 606 nsPtr->flags |= NS_DYING; 607 if (nsPtr->parentPtr != NULL) { 608 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, 609 nsPtr->name); 610 if (entryPtr != NULL) { 611 Tcl_DeleteHashEntry(entryPtr); 612 } 613 } 614 nsPtr->parentPtr = NULL; 615 } else if (!(nsPtr->flags & NS_KILLED)) { 616 /* 617 * Delete the namespace and everything in it. If this is the global 618 * namespace, then clear it but don't free its storage unless the 619 * interpreter is being torn down. Set the NS_KILLED flag to avoid 620 * recursive calls here - if the namespace is really in the process of 621 * being deleted, ignore any second call. 622 */ 623 624 nsPtr->flags |= (NS_DYING|NS_KILLED); 625 626 TclTeardownNamespace(nsPtr); 627 628 if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) { 629 /* 630 * If this is the global namespace, then it may have residual 631 * "errorInfo" and "errorCode" variables for errors that 632 * occurred while it was being torn down. Try to clear the 633 * variable list one last time. 634 */ 635 636 TclDeleteNamespaceVars(nsPtr); 637 638 Tcl_DeleteHashTable(&nsPtr->childTable); 639 Tcl_DeleteHashTable(&nsPtr->cmdTable); 640 641 /* 642 * If the reference count is 0, then discard the namespace. 643 * Otherwise, mark it as "dead" so that it can't be used. 644 */ 645 646 if (nsPtr->refCount == 0) { 647 NamespaceFree(nsPtr); 648 } else { 649 nsPtr->flags |= NS_DEAD; 650 } 651 } else { 652 /* 653 * We didn't really kill it, so remove the KILLED marks, so 654 * it can get killed later, avoiding mem leaks 655 */ 656 nsPtr->flags &= ~(NS_DYING|NS_KILLED); 657 } 658 } 659} 660 661/* 662 *---------------------------------------------------------------------- 663 * 664 * TclTeardownNamespace -- 665 * 666 * Used internally to dismantle and unlink a namespace when it is 667 * deleted. Divorces the namespace from its parent, and deletes all 668 * commands, variables, and child namespaces. 669 * 670 * This is kept separate from Tcl_DeleteNamespace so that the global 671 * namespace can be handled specially. Global variables like 672 * "errorInfo" and "errorCode" need to remain intact while other 673 * namespaces and commands are torn down, in case any errors occur. 674 * 675 * Results: 676 * None. 677 * 678 * Side effects: 679 * Removes this namespace from its parent's child namespace hashtable. 680 * Deletes all commands, variables and namespaces in this namespace. 681 * If this is the global namespace, the "errorInfo" and "errorCode" 682 * variables are left alone and deleted later. 683 * 684 *---------------------------------------------------------------------- 685 */ 686 687void 688TclTeardownNamespace(nsPtr) 689 register Namespace *nsPtr; /* Points to the namespace to be dismantled 690 * and unlinked from its parent. */ 691{ 692 Interp *iPtr = (Interp *) nsPtr->interp; 693 register Tcl_HashEntry *entryPtr; 694 Tcl_HashSearch search; 695 Tcl_Namespace *childNsPtr; 696 Tcl_Command cmd; 697 Namespace *globalNsPtr = 698 (Namespace *) Tcl_GetGlobalNamespace((Tcl_Interp *) iPtr); 699 int i; 700 701 /* 702 * Start by destroying the namespace's variable table, 703 * since variables might trigger traces. 704 */ 705 706 if (nsPtr == globalNsPtr) { 707 /* 708 * This is the global namespace. Tearing it down will destroy the 709 * ::errorInfo and ::errorCode variables. We save and restore them 710 * in case there are any errors in progress, so the error details 711 * they contain will not be lost. See test namespace-8.5 712 */ 713 714 Tcl_Obj *errorInfo = Tcl_GetVar2Ex(nsPtr->interp, "errorInfo", 715 NULL, TCL_GLOBAL_ONLY); 716 Tcl_Obj *errorCode = Tcl_GetVar2Ex(nsPtr->interp, "errorCode", 717 NULL, TCL_GLOBAL_ONLY); 718 719 if (errorInfo) { 720 Tcl_IncrRefCount(errorInfo); 721 } 722 if (errorCode) { 723 Tcl_IncrRefCount(errorCode); 724 } 725 726 TclDeleteNamespaceVars(nsPtr); 727 Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); 728 729 if (errorInfo) { 730 Tcl_SetVar2Ex(nsPtr->interp, "errorInfo", NULL, 731 errorInfo, TCL_GLOBAL_ONLY); 732 Tcl_DecrRefCount(errorInfo); 733 } 734 if (errorCode) { 735 Tcl_SetVar2Ex(nsPtr->interp, "errorCode", NULL, 736 errorCode, TCL_GLOBAL_ONLY); 737 Tcl_DecrRefCount(errorCode); 738 } 739 } else { 740 /* 741 * Variable table should be cleared but not freed! TclDeleteVars 742 * frees it, so we reinitialize it afterwards. 743 */ 744 745 TclDeleteNamespaceVars(nsPtr); 746 Tcl_InitHashTable(&nsPtr->varTable, TCL_STRING_KEYS); 747 } 748 749 /* 750 * Delete all commands in this namespace. Be careful when traversing the 751 * hash table: when each command is deleted, it removes itself from the 752 * command table. 753 */ 754 755 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 756 entryPtr != NULL; 757 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) { 758 cmd = (Tcl_Command) Tcl_GetHashValue(entryPtr); 759 Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd); 760 } 761 Tcl_DeleteHashTable(&nsPtr->cmdTable); 762 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS); 763 764 /* 765 * Remove the namespace from its parent's child hashtable. 766 */ 767 768 if (nsPtr->parentPtr != NULL) { 769 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable, 770 nsPtr->name); 771 if (entryPtr != NULL) { 772 Tcl_DeleteHashEntry(entryPtr); 773 } 774 } 775 nsPtr->parentPtr = NULL; 776 777 /* 778 * Delete all the child namespaces. 779 * 780 * BE CAREFUL: When each child is deleted, it will divorce 781 * itself from its parent. You can't traverse a hash table 782 * properly if its elements are being deleted. We use only 783 * the Tcl_FirstHashEntry function to be safe. 784 */ 785 786 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); 787 entryPtr != NULL; 788 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) { 789 childNsPtr = (Tcl_Namespace *) Tcl_GetHashValue(entryPtr); 790 Tcl_DeleteNamespace(childNsPtr); 791 } 792 793 /* 794 * Free the namespace's export pattern array. 795 */ 796 797 if (nsPtr->exportArrayPtr != NULL) { 798 for (i = 0; i < nsPtr->numExportPatterns; i++) { 799 ckfree(nsPtr->exportArrayPtr[i]); 800 } 801 ckfree((char *) nsPtr->exportArrayPtr); 802 nsPtr->exportArrayPtr = NULL; 803 nsPtr->numExportPatterns = 0; 804 nsPtr->maxExportPatterns = 0; 805 } 806 807 /* 808 * Free any client data associated with the namespace. 809 */ 810 811 if (nsPtr->deleteProc != NULL) { 812 (*nsPtr->deleteProc)(nsPtr->clientData); 813 } 814 nsPtr->deleteProc = NULL; 815 nsPtr->clientData = NULL; 816 817 /* 818 * Reset the namespace's id field to ensure that this namespace won't 819 * be interpreted as valid by, e.g., the cache validation code for 820 * cached command references in Tcl_GetCommandFromObj. 821 */ 822 823 nsPtr->nsId = 0; 824} 825 826/* 827 *---------------------------------------------------------------------- 828 * 829 * NamespaceFree -- 830 * 831 * Called after a namespace has been deleted, when its 832 * reference count reaches 0. Frees the data structure 833 * representing the namespace. 834 * 835 * Results: 836 * None. 837 * 838 * Side effects: 839 * None. 840 * 841 *---------------------------------------------------------------------- 842 */ 843 844static void 845NamespaceFree(nsPtr) 846 register Namespace *nsPtr; /* Points to the namespace to free. */ 847{ 848 /* 849 * Most of the namespace's contents are freed when the namespace is 850 * deleted by Tcl_DeleteNamespace. All that remains is to free its names 851 * (for error messages), and the structure itself. 852 */ 853 854 ckfree(nsPtr->name); 855 ckfree(nsPtr->fullName); 856 857 ckfree((char *) nsPtr); 858} 859 860 861/* 862 *---------------------------------------------------------------------- 863 * 864 * Tcl_Export -- 865 * 866 * Makes all the commands matching a pattern available to later be 867 * imported from the namespace specified by namespacePtr (or the 868 * current namespace if namespacePtr is NULL). The specified pattern is 869 * appended onto the namespace's export pattern list, which is 870 * optionally cleared beforehand. 871 * 872 * Results: 873 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 874 * message in the interpreter's result) if something goes wrong. 875 * 876 * Side effects: 877 * Appends the export pattern onto the namespace's export list. 878 * Optionally reset the namespace's export pattern list. 879 * 880 *---------------------------------------------------------------------- 881 */ 882 883int 884Tcl_Export(interp, namespacePtr, pattern, resetListFirst) 885 Tcl_Interp *interp; /* Current interpreter. */ 886 Tcl_Namespace *namespacePtr; /* Points to the namespace from which 887 * commands are to be exported. NULL for 888 * the current namespace. */ 889 CONST char *pattern; /* String pattern indicating which commands 890 * to export. This pattern may not include 891 * any namespace qualifiers; only commands 892 * in the specified namespace may be 893 * exported. */ 894 int resetListFirst; /* If nonzero, resets the namespace's 895 * export list before appending. */ 896{ 897#define INIT_EXPORT_PATTERNS 5 898 Namespace *nsPtr, *exportNsPtr, *dummyPtr; 899 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 900 CONST char *simplePattern; 901 char *patternCpy; 902 int neededElems, len, i; 903 904 /* 905 * If the specified namespace is NULL, use the current namespace. 906 */ 907 908 if (namespacePtr == NULL) { 909 nsPtr = (Namespace *) currNsPtr; 910 } else { 911 nsPtr = (Namespace *) namespacePtr; 912 } 913 914 /* 915 * If resetListFirst is true (nonzero), clear the namespace's export 916 * pattern list. 917 */ 918 919 if (resetListFirst) { 920 if (nsPtr->exportArrayPtr != NULL) { 921 for (i = 0; i < nsPtr->numExportPatterns; i++) { 922 ckfree(nsPtr->exportArrayPtr[i]); 923 } 924 ckfree((char *) nsPtr->exportArrayPtr); 925 nsPtr->exportArrayPtr = NULL; 926 nsPtr->numExportPatterns = 0; 927 nsPtr->maxExportPatterns = 0; 928 } 929 } 930 931 /* 932 * Check that the pattern doesn't have namespace qualifiers. 933 */ 934 935 TclGetNamespaceForQualName(interp, pattern, nsPtr, 936 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 937 &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 938 939 if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) { 940 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 941 "invalid export pattern \"", pattern, 942 "\": pattern can't specify a namespace", 943 (char *) NULL); 944 return TCL_ERROR; 945 } 946 947 /* 948 * Make sure that we don't already have the pattern in the array 949 */ 950 if (nsPtr->exportArrayPtr != NULL) { 951 for (i = 0; i < nsPtr->numExportPatterns; i++) { 952 if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) { 953 /* 954 * The pattern already exists in the list 955 */ 956 return TCL_OK; 957 } 958 } 959 } 960 961 /* 962 * Make sure there is room in the namespace's pattern array for the 963 * new pattern. 964 */ 965 966 neededElems = nsPtr->numExportPatterns + 1; 967 if (nsPtr->exportArrayPtr == NULL) { 968 nsPtr->exportArrayPtr = (char **) 969 ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *))); 970 nsPtr->numExportPatterns = 0; 971 nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS; 972 } else if (neededElems > nsPtr->maxExportPatterns) { 973 int numNewElems = 2 * nsPtr->maxExportPatterns; 974 size_t currBytes = nsPtr->numExportPatterns * sizeof(char *); 975 size_t newBytes = numNewElems * sizeof(char *); 976 char **newPtr = (char **) ckalloc((unsigned) newBytes); 977 978 memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr, 979 currBytes); 980 ckfree((char *) nsPtr->exportArrayPtr); 981 nsPtr->exportArrayPtr = (char **) newPtr; 982 nsPtr->maxExportPatterns = numNewElems; 983 } 984 985 /* 986 * Add the pattern to the namespace's array of export patterns. 987 */ 988 989 len = strlen(pattern); 990 patternCpy = (char *) ckalloc((unsigned) (len + 1)); 991 strcpy(patternCpy, pattern); 992 993 nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; 994 nsPtr->numExportPatterns++; 995 return TCL_OK; 996#undef INIT_EXPORT_PATTERNS 997} 998 999/* 1000 *---------------------------------------------------------------------- 1001 * 1002 * Tcl_AppendExportList -- 1003 * 1004 * Appends onto the argument object the list of export patterns for the 1005 * specified namespace. 1006 * 1007 * Results: 1008 * The return value is normally TCL_OK; in this case the object 1009 * referenced by objPtr has each export pattern appended to it. If an 1010 * error occurs, TCL_ERROR is returned and the interpreter's result 1011 * holds an error message. 1012 * 1013 * Side effects: 1014 * If necessary, the object referenced by objPtr is converted into 1015 * a list object. 1016 * 1017 *---------------------------------------------------------------------- 1018 */ 1019 1020int 1021Tcl_AppendExportList(interp, namespacePtr, objPtr) 1022 Tcl_Interp *interp; /* Interpreter used for error reporting. */ 1023 Tcl_Namespace *namespacePtr; /* Points to the namespace whose export 1024 * pattern list is appended onto objPtr. 1025 * NULL for the current namespace. */ 1026 Tcl_Obj *objPtr; /* Points to the Tcl object onto which the 1027 * export pattern list is appended. */ 1028{ 1029 Namespace *nsPtr; 1030 int i, result; 1031 1032 /* 1033 * If the specified namespace is NULL, use the current namespace. 1034 */ 1035 1036 if (namespacePtr == NULL) { 1037 nsPtr = (Namespace *) (Namespace *) Tcl_GetCurrentNamespace(interp); 1038 } else { 1039 nsPtr = (Namespace *) namespacePtr; 1040 } 1041 1042 /* 1043 * Append the export pattern list onto objPtr. 1044 */ 1045 1046 for (i = 0; i < nsPtr->numExportPatterns; i++) { 1047 result = Tcl_ListObjAppendElement(interp, objPtr, 1048 Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1)); 1049 if (result != TCL_OK) { 1050 return result; 1051 } 1052 } 1053 return TCL_OK; 1054} 1055 1056/* 1057 *---------------------------------------------------------------------- 1058 * 1059 * Tcl_Import -- 1060 * 1061 * Imports all of the commands matching a pattern into the namespace 1062 * specified by namespacePtr (or the current namespace if contextNsPtr 1063 * is NULL). This is done by creating a new command (the "imported 1064 * command") that points to the real command in its original namespace. 1065 * 1066 * If matching commands are on the autoload path but haven't been 1067 * loaded yet, this command forces them to be loaded, then creates 1068 * the links to them. 1069 * 1070 * Results: 1071 * Returns TCL_OK if successful, or TCL_ERROR (along with an error 1072 * message in the interpreter's result) if something goes wrong. 1073 * 1074 * Side effects: 1075 * Creates new commands in the importing namespace. These indirect 1076 * calls back to the real command and are deleted if the real commands 1077 * are deleted. 1078 * 1079 *---------------------------------------------------------------------- 1080 */ 1081 1082int 1083Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) 1084 Tcl_Interp *interp; /* Current interpreter. */ 1085 Tcl_Namespace *namespacePtr; /* Points to the namespace into which the 1086 * commands are to be imported. NULL for 1087 * the current namespace. */ 1088 CONST char *pattern; /* String pattern indicating which commands 1089 * to import. This pattern should be 1090 * qualified by the name of the namespace 1091 * from which to import the command(s). */ 1092 int allowOverwrite; /* If nonzero, allow existing commands to 1093 * be overwritten by imported commands. 1094 * If 0, return an error if an imported 1095 * cmd conflicts with an existing one. */ 1096{ 1097 Interp *iPtr = (Interp *) interp; 1098 Namespace *nsPtr, *importNsPtr, *dummyPtr; 1099 Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 1100 CONST char *simplePattern; 1101 char *cmdName; 1102 register Tcl_HashEntry *hPtr; 1103 Tcl_HashSearch search; 1104 Command *cmdPtr; 1105 ImportRef *refPtr; 1106 Tcl_Command autoCmd, importedCmd; 1107 ImportedCmdData *dataPtr; 1108 int wasExported, i, result; 1109 1110 /* 1111 * If the specified namespace is NULL, use the current namespace. 1112 */ 1113 1114 if (namespacePtr == NULL) { 1115 nsPtr = (Namespace *) currNsPtr; 1116 } else { 1117 nsPtr = (Namespace *) namespacePtr; 1118 } 1119 1120 /* 1121 * First, invoke the "auto_import" command with the pattern 1122 * being imported. This command is part of the Tcl library. 1123 * It looks for imported commands in autoloaded libraries and 1124 * loads them in. That way, they will be found when we try 1125 * to create links below. 1126 */ 1127 1128 autoCmd = Tcl_FindCommand(interp, "auto_import", 1129 (Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY); 1130 1131 if (autoCmd != NULL) { 1132 Tcl_Obj *objv[2]; 1133 1134 objv[0] = Tcl_NewStringObj("auto_import", -1); 1135 Tcl_IncrRefCount(objv[0]); 1136 objv[1] = Tcl_NewStringObj(pattern, -1); 1137 Tcl_IncrRefCount(objv[1]); 1138 1139 cmdPtr = (Command *) autoCmd; 1140 result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, 1141 2, objv); 1142 1143 Tcl_DecrRefCount(objv[0]); 1144 Tcl_DecrRefCount(objv[1]); 1145 1146 if (result != TCL_OK) { 1147 return TCL_ERROR; 1148 } 1149 Tcl_ResetResult(interp); 1150 } 1151 1152 /* 1153 * From the pattern, find the namespace from which we are importing 1154 * and get the simple pattern (no namespace qualifiers or ::'s) at 1155 * the end. 1156 */ 1157 1158 if (strlen(pattern) == 0) { 1159 Tcl_SetStringObj(Tcl_GetObjResult(interp), 1160 "empty import pattern", -1); 1161 return TCL_ERROR; 1162 } 1163 TclGetNamespaceForQualName(interp, pattern, nsPtr, 1164 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 1165 &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 1166 1167 if (importNsPtr == NULL) { 1168 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1169 "unknown namespace in import pattern \"", 1170 pattern, "\"", (char *) NULL); 1171 return TCL_ERROR; 1172 } 1173 if (importNsPtr == nsPtr) { 1174 if (pattern == simplePattern) { 1175 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1176 "no namespace specified in import pattern \"", pattern, 1177 "\"", (char *) NULL); 1178 } else { 1179 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1180 "import pattern \"", pattern, 1181 "\" tries to import from namespace \"", 1182 importNsPtr->name, "\" into itself", (char *) NULL); 1183 } 1184 return TCL_ERROR; 1185 } 1186 1187 /* 1188 * Scan through the command table in the source namespace and look for 1189 * exported commands that match the string pattern. Create an "imported 1190 * command" in the current namespace for each imported command; these 1191 * commands redirect their invocations to the "real" command. 1192 */ 1193 1194 for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search); 1195 (hPtr != NULL); 1196 hPtr = Tcl_NextHashEntry(&search)) { 1197 cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr); 1198 if (Tcl_StringMatch(cmdName, simplePattern)) { 1199 /* 1200 * The command cmdName in the source namespace matches the 1201 * pattern. Check whether it was exported. If it wasn't, 1202 * we ignore it. 1203 */ 1204 Tcl_HashEntry *found; 1205 1206 wasExported = 0; 1207 for (i = 0; i < importNsPtr->numExportPatterns; i++) { 1208 if (Tcl_StringMatch(cmdName, 1209 importNsPtr->exportArrayPtr[i])) { 1210 wasExported = 1; 1211 break; 1212 } 1213 } 1214 if (!wasExported) { 1215 continue; 1216 } 1217 1218 /* 1219 * Unless there is a name clash, create an imported command 1220 * in the current namespace that refers to cmdPtr. 1221 */ 1222 1223 found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName); 1224 if ((found == NULL) || allowOverwrite) { 1225 /* 1226 * Create the imported command and its client data. 1227 * To create the new command in the current namespace, 1228 * generate a fully qualified name for it. 1229 */ 1230 1231 Tcl_DString ds; 1232 1233 Tcl_DStringInit(&ds); 1234 Tcl_DStringAppend(&ds, nsPtr->fullName, -1); 1235 if (nsPtr != iPtr->globalNsPtr) { 1236 Tcl_DStringAppend(&ds, "::", 2); 1237 } 1238 Tcl_DStringAppend(&ds, cmdName, -1); 1239 1240 /* 1241 * Check whether creating the new imported command in the 1242 * current namespace would create a cycle of imported 1243 * command references. 1244 */ 1245 1246 cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 1247 if ((found != NULL) 1248 && cmdPtr->deleteProc == DeleteImportedCmd) { 1249 1250 Command *overwrite = (Command *) Tcl_GetHashValue(found); 1251 Command *link = cmdPtr; 1252 while (link->deleteProc == DeleteImportedCmd) { 1253 ImportedCmdData *dataPtr; 1254 1255 dataPtr = (ImportedCmdData *) link->objClientData; 1256 link = dataPtr->realCmdPtr; 1257 if (overwrite == link) { 1258 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1259 "import pattern \"", pattern, 1260 "\" would create a loop containing ", 1261 "command \"", Tcl_DStringValue(&ds), 1262 "\"", (char *) NULL); 1263 Tcl_DStringFree(&ds); 1264 return TCL_ERROR; 1265 } 1266 } 1267 } 1268 1269 dataPtr = (ImportedCmdData *) 1270 ckalloc(sizeof(ImportedCmdData)); 1271 importedCmd = Tcl_CreateObjCommand(interp, 1272 Tcl_DStringValue(&ds), InvokeImportedCmd, 1273 (ClientData) dataPtr, DeleteImportedCmd); 1274 dataPtr->realCmdPtr = cmdPtr; 1275 dataPtr->selfPtr = (Command *) importedCmd; 1276 dataPtr->selfPtr->compileProc = cmdPtr->compileProc; 1277 Tcl_DStringFree(&ds); 1278 1279 /* 1280 * Create an ImportRef structure describing this new import 1281 * command and add it to the import ref list in the "real" 1282 * command. 1283 */ 1284 1285 refPtr = (ImportRef *) ckalloc(sizeof(ImportRef)); 1286 refPtr->importedCmdPtr = (Command *) importedCmd; 1287 refPtr->nextPtr = cmdPtr->importRefPtr; 1288 cmdPtr->importRefPtr = refPtr; 1289 } else { 1290 Command *overwrite = (Command *) Tcl_GetHashValue(found); 1291 if (overwrite->deleteProc == DeleteImportedCmd) { 1292 ImportedCmdData *dataPtr = 1293 (ImportedCmdData *) overwrite->objClientData; 1294 if (dataPtr->realCmdPtr 1295 == (Command *) Tcl_GetHashValue(hPtr)) { 1296 /* Repeated import of same command -- acceptable */ 1297 return TCL_OK; 1298 } 1299 } 1300 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1301 "can't import command \"", cmdName, 1302 "\": already exists", (char *) NULL); 1303 return TCL_ERROR; 1304 } 1305 } 1306 } 1307 return TCL_OK; 1308} 1309 1310/* 1311 *---------------------------------------------------------------------- 1312 * 1313 * Tcl_ForgetImport -- 1314 * 1315 * Deletes commands previously imported into the namespace indicated. The 1316 * by namespacePtr, or the current namespace of interp, when 1317 * namespacePtr is NULL. The pattern controls which imported commands 1318 * are deleted. A simple pattern, one without namespace separators, 1319 * matches the current command names of imported commands in the 1320 * namespace. Matching imported commands are deleted. A qualified 1321 * pattern is interpreted as deletion selection on the basis of where 1322 * the command is imported from. The original command and "first link" 1323 * command for each imported command are determined, and they are matched 1324 * against the pattern. A match leads to deletion of the imported 1325 * command. 1326 * 1327 * Results: 1328 * Returns TCL_ERROR and records an error message in the interp 1329 * result if a namespace qualified pattern refers to a namespace 1330 * that does not exist. Otherwise, returns TCL_OK. 1331 * 1332 * Side effects: 1333 * May delete commands. 1334 * 1335 *---------------------------------------------------------------------- 1336 */ 1337 1338int 1339Tcl_ForgetImport(interp, namespacePtr, pattern) 1340 Tcl_Interp *interp; /* Current interpreter. */ 1341 Tcl_Namespace *namespacePtr; /* Points to the namespace from which 1342 * previously imported commands should be 1343 * removed. NULL for current namespace. */ 1344 CONST char *pattern; /* String pattern indicating which imported 1345 * commands to remove. */ 1346{ 1347 Namespace *nsPtr, *sourceNsPtr, *dummyPtr; 1348 CONST char *simplePattern; 1349 char *cmdName; 1350 register Tcl_HashEntry *hPtr; 1351 Tcl_HashSearch search; 1352 1353 /* 1354 * If the specified namespace is NULL, use the current namespace. 1355 */ 1356 1357 if (namespacePtr == NULL) { 1358 nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 1359 } else { 1360 nsPtr = (Namespace *) namespacePtr; 1361 } 1362 1363 /* 1364 * Parse the pattern into its namespace-qualification (if any) 1365 * and the simple pattern. 1366 */ 1367 1368 TclGetNamespaceForQualName(interp, pattern, nsPtr, 1369 /*flags*/ (TCL_LEAVE_ERR_MSG | TCL_NAMESPACE_ONLY), 1370 &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern); 1371 1372 if (sourceNsPtr == NULL) { 1373 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1374 "unknown namespace in namespace forget pattern \"", 1375 pattern, "\"", (char *) NULL); 1376 return TCL_ERROR; 1377 } 1378 1379 if (strcmp(pattern, simplePattern) == 0) { 1380 /* 1381 * The pattern is simple. 1382 * Delete any imported commands that match it. 1383 */ 1384 1385 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); 1386 (hPtr != NULL); 1387 hPtr = Tcl_NextHashEntry(&search)) { 1388 Command *cmdPtr = (Command *) Tcl_GetHashValue(hPtr); 1389 if (cmdPtr->deleteProc != DeleteImportedCmd) { 1390 continue; 1391 } 1392 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr); 1393 if (Tcl_StringMatch(cmdName, simplePattern)) { 1394 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); 1395 } 1396 } 1397 return TCL_OK; 1398 } 1399 1400 /* The pattern was namespace-qualified */ 1401 1402 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL); 1403 hPtr = Tcl_NextHashEntry(&search)) { 1404 Tcl_CmdInfo info; 1405 Tcl_Command token = (Tcl_Command) Tcl_GetHashValue(hPtr); 1406 Tcl_Command origin = TclGetOriginalCommand(token); 1407 1408 if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) { 1409 continue; /* Not an imported command */ 1410 } 1411 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { 1412 /* 1413 * Original not in namespace we're matching. 1414 * Check the first link in the import chain. 1415 */ 1416 Command *cmdPtr = (Command *) token; 1417 ImportedCmdData *dataPtr = 1418 (ImportedCmdData *) cmdPtr->objClientData; 1419 Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr; 1420 if (firstToken == origin) { 1421 continue; 1422 } 1423 Tcl_GetCommandInfoFromToken(firstToken, &info); 1424 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) { 1425 continue; 1426 } 1427 origin = firstToken; 1428 } 1429 if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) { 1430 Tcl_DeleteCommandFromToken(interp, token); 1431 } 1432 } 1433 return TCL_OK; 1434} 1435 1436/* 1437 *---------------------------------------------------------------------- 1438 * 1439 * TclGetOriginalCommand -- 1440 * 1441 * An imported command is created in an namespace when a "real" command 1442 * is imported from another namespace. If the specified command is an 1443 * imported command, this procedure returns the original command it 1444 * refers to. 1445 * 1446 * Results: 1447 * If the command was imported into a sequence of namespaces a, b,...,n 1448 * where each successive namespace just imports the command from the 1449 * previous namespace, this procedure returns the Tcl_Command token in 1450 * the first namespace, a. Otherwise, if the specified command is not 1451 * an imported command, the procedure returns NULL. 1452 * 1453 * Side effects: 1454 * None. 1455 * 1456 *---------------------------------------------------------------------- 1457 */ 1458 1459Tcl_Command 1460TclGetOriginalCommand(command) 1461 Tcl_Command command; /* The imported command for which the 1462 * original command should be returned. */ 1463{ 1464 register Command *cmdPtr = (Command *) command; 1465 ImportedCmdData *dataPtr; 1466 1467 if (cmdPtr->deleteProc != DeleteImportedCmd) { 1468 return (Tcl_Command) NULL; 1469 } 1470 1471 while (cmdPtr->deleteProc == DeleteImportedCmd) { 1472 dataPtr = (ImportedCmdData *) cmdPtr->objClientData; 1473 cmdPtr = dataPtr->realCmdPtr; 1474 } 1475 return (Tcl_Command) cmdPtr; 1476} 1477 1478/* 1479 *---------------------------------------------------------------------- 1480 * 1481 * InvokeImportedCmd -- 1482 * 1483 * Invoked by Tcl whenever the user calls an imported command that 1484 * was created by Tcl_Import. Finds the "real" command (in another 1485 * namespace), and passes control to it. 1486 * 1487 * Results: 1488 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 1489 * 1490 * Side effects: 1491 * Returns a result in the interpreter's result object. If anything 1492 * goes wrong, the result object is set to an error message. 1493 * 1494 *---------------------------------------------------------------------- 1495 */ 1496 1497static int 1498InvokeImportedCmd(clientData, interp, objc, objv) 1499 ClientData clientData; /* Points to the imported command's 1500 * ImportedCmdData structure. */ 1501 Tcl_Interp *interp; /* Current interpreter. */ 1502 int objc; /* Number of arguments. */ 1503 Tcl_Obj *CONST objv[]; /* The argument objects. */ 1504{ 1505 register ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; 1506 register Command *realCmdPtr = dataPtr->realCmdPtr; 1507 1508 return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, 1509 objc, objv); 1510} 1511 1512/* 1513 *---------------------------------------------------------------------- 1514 * 1515 * DeleteImportedCmd -- 1516 * 1517 * Invoked by Tcl whenever an imported command is deleted. The "real" 1518 * command keeps a list of all the imported commands that refer to it, 1519 * so those imported commands can be deleted when the real command is 1520 * deleted. This procedure removes the imported command reference from 1521 * the real command's list, and frees up the memory associated with 1522 * the imported command. 1523 * 1524 * Results: 1525 * None. 1526 * 1527 * Side effects: 1528 * Removes the imported command from the real command's import list. 1529 * 1530 *---------------------------------------------------------------------- 1531 */ 1532 1533static void 1534DeleteImportedCmd(clientData) 1535 ClientData clientData; /* Points to the imported command's 1536 * ImportedCmdData structure. */ 1537{ 1538 ImportedCmdData *dataPtr = (ImportedCmdData *) clientData; 1539 Command *realCmdPtr = dataPtr->realCmdPtr; 1540 Command *selfPtr = dataPtr->selfPtr; 1541 register ImportRef *refPtr, *prevPtr; 1542 1543 prevPtr = NULL; 1544 for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL; 1545 refPtr = refPtr->nextPtr) { 1546 if (refPtr->importedCmdPtr == selfPtr) { 1547 /* 1548 * Remove *refPtr from real command's list of imported commands 1549 * that refer to it. 1550 */ 1551 1552 if (prevPtr == NULL) { /* refPtr is first in list */ 1553 realCmdPtr->importRefPtr = refPtr->nextPtr; 1554 } else { 1555 prevPtr->nextPtr = refPtr->nextPtr; 1556 } 1557 ckfree((char *) refPtr); 1558 ckfree((char *) dataPtr); 1559 return; 1560 } 1561 prevPtr = refPtr; 1562 } 1563 1564 panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references"); 1565} 1566 1567/* 1568 *---------------------------------------------------------------------- 1569 * 1570 * TclGetNamespaceForQualName -- 1571 * 1572 * Given a qualified name specifying a command, variable, or namespace, 1573 * and a namespace in which to resolve the name, this procedure returns 1574 * a pointer to the namespace that contains the item. A qualified name 1575 * consists of the "simple" name of an item qualified by the names of 1576 * an arbitrary number of containing namespace separated by "::"s. If 1577 * the qualified name starts with "::", it is interpreted absolutely 1578 * from the global namespace. Otherwise, it is interpreted relative to 1579 * the namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr 1580 * is NULL, the name is interpreted relative to the current namespace. 1581 * 1582 * A relative name like "foo::bar::x" can be found starting in either 1583 * the current namespace or in the global namespace. So each search 1584 * usually follows two tracks, and two possible namespaces are 1585 * returned. If the procedure sets either *nsPtrPtr or *altNsPtrPtr to 1586 * NULL, then that path failed. 1587 * 1588 * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is 1589 * sought only in the global :: namespace. The alternate search 1590 * (also) starting from the global namespace is ignored and 1591 * *altNsPtrPtr is set NULL. 1592 * 1593 * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified 1594 * name is sought only in the namespace specified by cxtNsPtr. The 1595 * alternate search starting from the global namespace is ignored and 1596 * *altNsPtrPtr is set NULL. If both TCL_GLOBAL_ONLY and 1597 * TCL_NAMESPACE_ONLY are specified, TCL_GLOBAL_ONLY is ignored and 1598 * the search starts from the namespace specified by cxtNsPtr. 1599 * 1600 * If "flags" contains CREATE_NS_IF_UNKNOWN, all namespace 1601 * components of the qualified name that cannot be found are 1602 * automatically created within their specified parent. This makes sure 1603 * that functions like Tcl_CreateCommand always succeed. There is no 1604 * alternate search path, so *altNsPtrPtr is set NULL. 1605 * 1606 * If "flags" contains FIND_ONLY_NS, the qualified name is treated as a 1607 * reference to a namespace, and the entire qualified name is 1608 * followed. If the name is relative, the namespace is looked up only 1609 * in the current namespace. A pointer to the namespace is stored in 1610 * *nsPtrPtr and NULL is stored in *simpleNamePtr. Otherwise, if 1611 * FIND_ONLY_NS is not specified, only the leading components are 1612 * treated as namespace names, and a pointer to the simple name of the 1613 * final component is stored in *simpleNamePtr. 1614 * 1615 * Results: 1616 * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible 1617 * namespaces which represent the last (containing) namespace in the 1618 * qualified name. If the procedure sets either *nsPtrPtr or *altNsPtrPtr 1619 * to NULL, then the search along that path failed. The procedure also 1620 * stores a pointer to the simple name of the final component in 1621 * *simpleNamePtr. If the qualified name is "::" or was treated as a 1622 * namespace reference (FIND_ONLY_NS), the procedure stores a pointer 1623 * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets 1624 * *simpleNamePtr to point to an empty string. 1625 * 1626 * If there is an error, this procedure returns TCL_ERROR. If "flags" 1627 * contains TCL_LEAVE_ERR_MSG, an error message is returned in the 1628 * interpreter's result object. Otherwise, the interpreter's result 1629 * object is left unchanged. 1630 * 1631 * *actualCxtPtrPtr is set to the actual context namespace. It is 1632 * set to the input context namespace pointer in cxtNsPtr. If cxtNsPtr 1633 * is NULL, it is set to the current namespace context. 1634 * 1635 * For backwards compatibility with the TclPro byte code loader, 1636 * this function always returns TCL_OK. 1637 * 1638 * Side effects: 1639 * If "flags" contains CREATE_NS_IF_UNKNOWN, new namespaces may be 1640 * created. 1641 * 1642 *---------------------------------------------------------------------- 1643 */ 1644 1645int 1646TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, 1647 nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) 1648 Tcl_Interp *interp; /* Interpreter in which to find the 1649 * namespace containing qualName. */ 1650 CONST char *qualName; /* A namespace-qualified name of an 1651 * command, variable, or namespace. */ 1652 Namespace *cxtNsPtr; /* The namespace in which to start the 1653 * search for qualName's namespace. If NULL 1654 * start from the current namespace. 1655 * Ignored if TCL_GLOBAL_ONLY is set. */ 1656 int flags; /* Flags controlling the search: an OR'd 1657 * combination of TCL_GLOBAL_ONLY, 1658 * TCL_NAMESPACE_ONLY, 1659 * CREATE_NS_IF_UNKNOWN, and 1660 * FIND_ONLY_NS. */ 1661 Namespace **nsPtrPtr; /* Address where procedure stores a pointer 1662 * to containing namespace if qualName is 1663 * found starting from *cxtNsPtr or, if 1664 * TCL_GLOBAL_ONLY is set, if qualName is 1665 * found in the global :: namespace. NULL 1666 * is stored otherwise. */ 1667 Namespace **altNsPtrPtr; /* Address where procedure stores a pointer 1668 * to containing namespace if qualName is 1669 * found starting from the global :: 1670 * namespace. NULL is stored if qualName 1671 * isn't found starting from :: or if the 1672 * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, 1673 * CREATE_NS_IF_UNKNOWN, FIND_ONLY_NS flag 1674 * is set. */ 1675 Namespace **actualCxtPtrPtr; /* Address where procedure stores a pointer 1676 * to the actual namespace from which the 1677 * search started. This is either cxtNsPtr, 1678 * the :: namespace if TCL_GLOBAL_ONLY was 1679 * specified, or the current namespace if 1680 * cxtNsPtr was NULL. */ 1681 CONST char **simpleNamePtr; /* Address where procedure stores the 1682 * simple name at end of the qualName, or 1683 * NULL if qualName is "::" or the flag 1684 * FIND_ONLY_NS was specified. */ 1685{ 1686 Interp *iPtr = (Interp *) interp; 1687 Namespace *nsPtr = cxtNsPtr; 1688 Namespace *altNsPtr; 1689 Namespace *globalNsPtr = iPtr->globalNsPtr; 1690 CONST char *start, *end; 1691 CONST char *nsName; 1692 Tcl_HashEntry *entryPtr; 1693 Tcl_DString buffer; 1694 int len; 1695 1696 /* 1697 * Determine the context namespace nsPtr in which to start the primary 1698 * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY 1699 * was specified, search from the global namespace. Otherwise, use the 1700 * namespace given in cxtNsPtr, or if that is NULL, use the current 1701 * namespace context. Note that we always treat two or more 1702 * adjacent ":"s as a namespace separator. 1703 */ 1704 1705 if (flags & TCL_GLOBAL_ONLY) { 1706 nsPtr = globalNsPtr; 1707 } else if (nsPtr == NULL) { 1708 if (iPtr->varFramePtr != NULL) { 1709 nsPtr = iPtr->varFramePtr->nsPtr; 1710 } else { 1711 nsPtr = iPtr->globalNsPtr; 1712 } 1713 } 1714 1715 start = qualName; /* pts to start of qualifying namespace */ 1716 if ((*qualName == ':') && (*(qualName+1) == ':')) { 1717 start = qualName+2; /* skip over the initial :: */ 1718 while (*start == ':') { 1719 start++; /* skip over a subsequent : */ 1720 } 1721 nsPtr = globalNsPtr; 1722 if (*start == '\0') { /* qualName is just two or more ":"s */ 1723 *nsPtrPtr = globalNsPtr; 1724 *altNsPtrPtr = NULL; 1725 *actualCxtPtrPtr = globalNsPtr; 1726 *simpleNamePtr = start; /* points to empty string */ 1727 return TCL_OK; 1728 } 1729 } 1730 *actualCxtPtrPtr = nsPtr; 1731 1732 /* 1733 * Start an alternate search path starting with the global namespace. 1734 * However, if the starting context is the global namespace, or if the 1735 * flag is set to search only the namespace *cxtNsPtr, ignore the 1736 * alternate search path. 1737 */ 1738 1739 altNsPtr = globalNsPtr; 1740 if ((nsPtr == globalNsPtr) 1741 || (flags & (TCL_NAMESPACE_ONLY | FIND_ONLY_NS))) { 1742 altNsPtr = NULL; 1743 } 1744 1745 /* 1746 * Loop to resolve each namespace qualifier in qualName. 1747 */ 1748 1749 Tcl_DStringInit(&buffer); 1750 end = start; 1751 while (*start != '\0') { 1752 /* 1753 * Find the next namespace qualifier (i.e., a name ending in "::") 1754 * or the end of the qualified name (i.e., a name ending in "\0"). 1755 * Set len to the number of characters, starting from start, 1756 * in the name; set end to point after the "::"s or at the "\0". 1757 */ 1758 1759 len = 0; 1760 for (end = start; *end != '\0'; end++) { 1761 if ((*end == ':') && (*(end+1) == ':')) { 1762 end += 2; /* skip over the initial :: */ 1763 while (*end == ':') { 1764 end++; /* skip over the subsequent : */ 1765 } 1766 break; /* exit for loop; end is after ::'s */ 1767 } 1768 len++; 1769 } 1770 1771 if ((*end == '\0') 1772 && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) { 1773 /* 1774 * qualName ended with a simple name at start. If FIND_ONLY_NS 1775 * was specified, look this up as a namespace. Otherwise, 1776 * start is the name of a cmd or var and we are done. 1777 */ 1778 1779 if (flags & FIND_ONLY_NS) { 1780 nsName = start; 1781 } else { 1782 *nsPtrPtr = nsPtr; 1783 *altNsPtrPtr = altNsPtr; 1784 *simpleNamePtr = start; 1785 Tcl_DStringFree(&buffer); 1786 return TCL_OK; 1787 } 1788 } else { 1789 /* 1790 * start points to the beginning of a namespace qualifier ending 1791 * in "::". end points to the start of a name in that namespace 1792 * that might be empty. Copy the namespace qualifier to a 1793 * buffer so it can be null terminated. We can't modify the 1794 * incoming qualName since it may be a string constant. 1795 */ 1796 1797 Tcl_DStringSetLength(&buffer, 0); 1798 Tcl_DStringAppend(&buffer, start, len); 1799 nsName = Tcl_DStringValue(&buffer); 1800 } 1801 1802 /* 1803 * Look up the namespace qualifier nsName in the current namespace 1804 * context. If it isn't found but CREATE_NS_IF_UNKNOWN is set, 1805 * create that qualifying namespace. This is needed for procedures 1806 * like Tcl_CreateCommand that cannot fail. 1807 */ 1808 1809 if (nsPtr != NULL) { 1810 entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName); 1811 if (entryPtr != NULL) { 1812 nsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); 1813 } else if (flags & CREATE_NS_IF_UNKNOWN) { 1814 Tcl_CallFrame frame; 1815 1816 (void) Tcl_PushCallFrame(interp, &frame, 1817 (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0); 1818 1819 nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName, 1820 (ClientData) NULL, (Tcl_NamespaceDeleteProc *) NULL); 1821 Tcl_PopCallFrame(interp); 1822 1823 if (nsPtr == NULL) { 1824 panic("Could not create namespace '%s'", nsName); 1825 } 1826 } else { /* namespace not found and wasn't created */ 1827 nsPtr = NULL; 1828 } 1829 } 1830 1831 /* 1832 * Look up the namespace qualifier in the alternate search path too. 1833 */ 1834 1835 if (altNsPtr != NULL) { 1836 entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName); 1837 if (entryPtr != NULL) { 1838 altNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); 1839 } else { 1840 altNsPtr = NULL; 1841 } 1842 } 1843 1844 /* 1845 * If both search paths have failed, return NULL results. 1846 */ 1847 1848 if ((nsPtr == NULL) && (altNsPtr == NULL)) { 1849 *nsPtrPtr = NULL; 1850 *altNsPtrPtr = NULL; 1851 *simpleNamePtr = NULL; 1852 Tcl_DStringFree(&buffer); 1853 return TCL_OK; 1854 } 1855 1856 start = end; 1857 } 1858 1859 /* 1860 * We ignore trailing "::"s in a namespace name, but in a command or 1861 * variable name, trailing "::"s refer to the cmd or var named {}. 1862 */ 1863 1864 if ((flags & FIND_ONLY_NS) 1865 || ((end > start ) && (*(end-1) != ':'))) { 1866 *simpleNamePtr = NULL; /* found namespace name */ 1867 } else { 1868 *simpleNamePtr = end; /* found cmd/var: points to empty string */ 1869 } 1870 1871 /* 1872 * As a special case, if we are looking for a namespace and qualName 1873 * is "" and the current active namespace (nsPtr) is not the global 1874 * namespace, return NULL (no namespace was found). This is because 1875 * namespaces can not have empty names except for the global namespace. 1876 */ 1877 1878 if ((flags & FIND_ONLY_NS) && (*qualName == '\0') 1879 && (nsPtr != globalNsPtr)) { 1880 nsPtr = NULL; 1881 } 1882 1883 *nsPtrPtr = nsPtr; 1884 *altNsPtrPtr = altNsPtr; 1885 Tcl_DStringFree(&buffer); 1886 return TCL_OK; 1887} 1888 1889/* 1890 *---------------------------------------------------------------------- 1891 * 1892 * Tcl_FindNamespace -- 1893 * 1894 * Searches for a namespace. 1895 * 1896 * Results: 1897 * Returns a pointer to the namespace if it is found. Otherwise, 1898 * returns NULL and leaves an error message in the interpreter's 1899 * result object if "flags" contains TCL_LEAVE_ERR_MSG. 1900 * 1901 * Side effects: 1902 * None. 1903 * 1904 *---------------------------------------------------------------------- 1905 */ 1906 1907Tcl_Namespace * 1908Tcl_FindNamespace(interp, name, contextNsPtr, flags) 1909 Tcl_Interp *interp; /* The interpreter in which to find the 1910 * namespace. */ 1911 CONST char *name; /* Namespace name. If it starts with "::", 1912 * will be looked up in global namespace. 1913 * Else, looked up first in contextNsPtr 1914 * (current namespace if contextNsPtr is 1915 * NULL), then in global namespace. */ 1916 Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set 1917 * or if the name starts with "::". 1918 * Otherwise, points to namespace in which 1919 * to resolve name; if NULL, look up name 1920 * in the current namespace. */ 1921 register int flags; /* Flags controlling namespace lookup: an 1922 * OR'd combination of TCL_GLOBAL_ONLY and 1923 * TCL_LEAVE_ERR_MSG flags. */ 1924{ 1925 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; 1926 CONST char *dummy; 1927 1928 /* 1929 * Find the namespace(s) that contain the specified namespace name. 1930 * Add the FIND_ONLY_NS flag to resolve the name all the way down 1931 * to its last component, a namespace. 1932 */ 1933 1934 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 1935 (flags | FIND_ONLY_NS), &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); 1936 1937 if (nsPtr != NULL) { 1938 return (Tcl_Namespace *) nsPtr; 1939 } else if (flags & TCL_LEAVE_ERR_MSG) { 1940 Tcl_ResetResult(interp); 1941 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 1942 "unknown namespace \"", name, "\"", (char *) NULL); 1943 } 1944 return NULL; 1945} 1946 1947/* 1948 *---------------------------------------------------------------------- 1949 * 1950 * Tcl_FindCommand -- 1951 * 1952 * Searches for a command. 1953 * 1954 * Results: 1955 * Returns a token for the command if it is found. Otherwise, if it 1956 * can't be found or there is an error, returns NULL and leaves an 1957 * error message in the interpreter's result object if "flags" 1958 * contains TCL_LEAVE_ERR_MSG. 1959 * 1960 * Side effects: 1961 * None. 1962 * 1963 *---------------------------------------------------------------------- 1964 */ 1965 1966Tcl_Command 1967Tcl_FindCommand(interp, name, contextNsPtr, flags) 1968 Tcl_Interp *interp; /* The interpreter in which to find the 1969 * command and to report errors. */ 1970 CONST char *name; /* Command's name. If it starts with "::", 1971 * will be looked up in global namespace. 1972 * Else, looked up first in contextNsPtr 1973 * (current namespace if contextNsPtr is 1974 * NULL), then in global namespace. */ 1975 Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. 1976 * Otherwise, points to namespace in which 1977 * to resolve name. If NULL, look up name 1978 * in the current namespace. */ 1979 int flags; /* An OR'd combination of flags: 1980 * TCL_GLOBAL_ONLY (look up name only in 1981 * global namespace), TCL_NAMESPACE_ONLY 1982 * (look up only in contextNsPtr, or the 1983 * current namespace if contextNsPtr is 1984 * NULL), and TCL_LEAVE_ERR_MSG. If both 1985 * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY 1986 * are given, TCL_GLOBAL_ONLY is 1987 * ignored. */ 1988{ 1989 Interp *iPtr = (Interp*)interp; 1990 1991 ResolverScheme *resPtr; 1992 Namespace *nsPtr[2], *cxtNsPtr; 1993 CONST char *simpleName; 1994 register Tcl_HashEntry *entryPtr; 1995 register Command *cmdPtr; 1996 register int search; 1997 int result; 1998 Tcl_Command cmd; 1999 2000 /* 2001 * If this namespace has a command resolver, then give it first 2002 * crack at the command resolution. If the interpreter has any 2003 * command resolvers, consult them next. The command resolver 2004 * procedures may return a Tcl_Command value, they may signal 2005 * to continue onward, or they may signal an error. 2006 */ 2007 if ((flags & TCL_GLOBAL_ONLY) != 0) { 2008 cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 2009 } 2010 else if (contextNsPtr != NULL) { 2011 cxtNsPtr = (Namespace *) contextNsPtr; 2012 } 2013 else { 2014 cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2015 } 2016 2017 if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) { 2018 resPtr = iPtr->resolverPtr; 2019 2020 if (cxtNsPtr->cmdResProc) { 2021 result = (*cxtNsPtr->cmdResProc)(interp, name, 2022 (Tcl_Namespace *) cxtNsPtr, flags, &cmd); 2023 } else { 2024 result = TCL_CONTINUE; 2025 } 2026 2027 while (result == TCL_CONTINUE && resPtr) { 2028 if (resPtr->cmdResProc) { 2029 result = (*resPtr->cmdResProc)(interp, name, 2030 (Tcl_Namespace *) cxtNsPtr, flags, &cmd); 2031 } 2032 resPtr = resPtr->nextPtr; 2033 } 2034 2035 if (result == TCL_OK) { 2036 return cmd; 2037 } 2038 else if (result != TCL_CONTINUE) { 2039 return (Tcl_Command) NULL; 2040 } 2041 } 2042 2043 /* 2044 * Find the namespace(s) that contain the command. 2045 */ 2046 2047 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 2048 flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); 2049 2050 /* 2051 * Look for the command in the command table of its namespace. 2052 * Be sure to check both possible search paths: from the specified 2053 * namespace context and from the global namespace. 2054 */ 2055 2056 cmdPtr = NULL; 2057 for (search = 0; (search < 2) && (cmdPtr == NULL); search++) { 2058 if ((nsPtr[search] != NULL) && (simpleName != NULL)) { 2059 entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable, 2060 simpleName); 2061 if (entryPtr != NULL) { 2062 cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); 2063 } 2064 } 2065 } 2066 2067 if (cmdPtr != NULL) { 2068 return (Tcl_Command) cmdPtr; 2069 } else if (flags & TCL_LEAVE_ERR_MSG) { 2070 Tcl_ResetResult(interp); 2071 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2072 "unknown command \"", name, "\"", (char *) NULL); 2073 } 2074 2075 return (Tcl_Command) NULL; 2076} 2077 2078/* 2079 *---------------------------------------------------------------------- 2080 * 2081 * Tcl_FindNamespaceVar -- 2082 * 2083 * Searches for a namespace variable, a variable not local to a 2084 * procedure. The variable can be either a scalar or an array, but 2085 * may not be an element of an array. 2086 * 2087 * Results: 2088 * Returns a token for the variable if it is found. Otherwise, if it 2089 * can't be found or there is an error, returns NULL and leaves an 2090 * error message in the interpreter's result object if "flags" 2091 * contains TCL_LEAVE_ERR_MSG. 2092 * 2093 * Side effects: 2094 * None. 2095 * 2096 *---------------------------------------------------------------------- 2097 */ 2098 2099Tcl_Var 2100Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) 2101 Tcl_Interp *interp; /* The interpreter in which to find the 2102 * variable. */ 2103 CONST char *name; /* Variable's name. If it starts with "::", 2104 * will be looked up in global namespace. 2105 * Else, looked up first in contextNsPtr 2106 * (current namespace if contextNsPtr is 2107 * NULL), then in global namespace. */ 2108 Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. 2109 * Otherwise, points to namespace in which 2110 * to resolve name. If NULL, look up name 2111 * in the current namespace. */ 2112 int flags; /* An OR'd combination of flags: 2113 * TCL_GLOBAL_ONLY (look up name only in 2114 * global namespace), TCL_NAMESPACE_ONLY 2115 * (look up only in contextNsPtr, or the 2116 * current namespace if contextNsPtr is 2117 * NULL), and TCL_LEAVE_ERR_MSG. If both 2118 * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY 2119 * are given, TCL_GLOBAL_ONLY is 2120 * ignored. */ 2121{ 2122 Interp *iPtr = (Interp*)interp; 2123 ResolverScheme *resPtr; 2124 Namespace *nsPtr[2], *cxtNsPtr; 2125 CONST char *simpleName; 2126 Tcl_HashEntry *entryPtr; 2127 Var *varPtr; 2128 register int search; 2129 int result; 2130 Tcl_Var var; 2131 2132 /* 2133 * If this namespace has a variable resolver, then give it first 2134 * crack at the variable resolution. It may return a Tcl_Var 2135 * value, it may signal to continue onward, or it may signal 2136 * an error. 2137 */ 2138 if ((flags & TCL_GLOBAL_ONLY) != 0) { 2139 cxtNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 2140 } 2141 else if (contextNsPtr != NULL) { 2142 cxtNsPtr = (Namespace *) contextNsPtr; 2143 } 2144 else { 2145 cxtNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2146 } 2147 2148 if (cxtNsPtr->varResProc != NULL || iPtr->resolverPtr != NULL) { 2149 resPtr = iPtr->resolverPtr; 2150 2151 if (cxtNsPtr->varResProc) { 2152 result = (*cxtNsPtr->varResProc)(interp, name, 2153 (Tcl_Namespace *) cxtNsPtr, flags, &var); 2154 } else { 2155 result = TCL_CONTINUE; 2156 } 2157 2158 while (result == TCL_CONTINUE && resPtr) { 2159 if (resPtr->varResProc) { 2160 result = (*resPtr->varResProc)(interp, name, 2161 (Tcl_Namespace *) cxtNsPtr, flags, &var); 2162 } 2163 resPtr = resPtr->nextPtr; 2164 } 2165 2166 if (result == TCL_OK) { 2167 return var; 2168 } 2169 else if (result != TCL_CONTINUE) { 2170 return (Tcl_Var) NULL; 2171 } 2172 } 2173 2174 /* 2175 * Find the namespace(s) that contain the variable. 2176 */ 2177 2178 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, 2179 flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); 2180 2181 /* 2182 * Look for the variable in the variable table of its namespace. 2183 * Be sure to check both possible search paths: from the specified 2184 * namespace context and from the global namespace. 2185 */ 2186 2187 varPtr = NULL; 2188 for (search = 0; (search < 2) && (varPtr == NULL); search++) { 2189 if ((nsPtr[search] != NULL) && (simpleName != NULL)) { 2190 entryPtr = Tcl_FindHashEntry(&nsPtr[search]->varTable, 2191 simpleName); 2192 if (entryPtr != NULL) { 2193 varPtr = (Var *) Tcl_GetHashValue(entryPtr); 2194 } 2195 } 2196 } 2197 if (varPtr != NULL) { 2198 return (Tcl_Var) varPtr; 2199 } else if (flags & TCL_LEAVE_ERR_MSG) { 2200 Tcl_ResetResult(interp); 2201 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2202 "unknown variable \"", name, "\"", (char *) NULL); 2203 } 2204 return (Tcl_Var) NULL; 2205} 2206 2207/* 2208 *---------------------------------------------------------------------- 2209 * 2210 * TclResetShadowedCmdRefs -- 2211 * 2212 * Called when a command is added to a namespace to check for existing 2213 * command references that the new command may invalidate. Consider the 2214 * following cases that could happen when you add a command "foo" to a 2215 * namespace "b": 2216 * 1. It could shadow a command named "foo" at the global scope. 2217 * If it does, all command references in the namespace "b" are 2218 * suspect. 2219 * 2. Suppose the namespace "b" resides in a namespace "a". 2220 * Then to "a" the new command "b::foo" could shadow another 2221 * command "b::foo" in the global namespace. If so, then all 2222 * command references in "a" are suspect. 2223 * The same checks are applied to all parent namespaces, until we 2224 * reach the global :: namespace. 2225 * 2226 * Results: 2227 * None. 2228 * 2229 * Side effects: 2230 * If the new command shadows an existing command, the cmdRefEpoch 2231 * counter is incremented in each namespace that sees the shadow. 2232 * This invalidates all command references that were previously cached 2233 * in that namespace. The next time the commands are used, they are 2234 * resolved from scratch. 2235 * 2236 *---------------------------------------------------------------------- 2237 */ 2238 2239void 2240TclResetShadowedCmdRefs(interp, newCmdPtr) 2241 Tcl_Interp *interp; /* Interpreter containing the new command. */ 2242 Command *newCmdPtr; /* Points to the new command. */ 2243{ 2244 char *cmdName; 2245 Tcl_HashEntry *hPtr; 2246 register Namespace *nsPtr; 2247 Namespace *trailNsPtr, *shadowNsPtr; 2248 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 2249 int found, i; 2250 2251 /* 2252 * This procedure generates an array used to hold the trail list. This 2253 * starts out with stack-allocated space but uses dynamically-allocated 2254 * storage if needed. 2255 */ 2256 2257 Namespace *(trailStorage[NUM_TRAIL_ELEMS]); 2258 Namespace **trailPtr = trailStorage; 2259 int trailFront = -1; 2260 int trailSize = NUM_TRAIL_ELEMS; 2261 2262 /* 2263 * Start at the namespace containing the new command, and work up 2264 * through the list of parents. Stop just before the global namespace, 2265 * since the global namespace can't "shadow" its own entries. 2266 * 2267 * The namespace "trail" list we build consists of the names of each 2268 * namespace that encloses the new command, in order from outermost to 2269 * innermost: for example, "a" then "b". Each iteration of this loop 2270 * eventually extends the trail upwards by one namespace, nsPtr. We use 2271 * this trail list to see if nsPtr (e.g. "a" in 2. above) could have 2272 * now-invalid cached command references. This will happen if nsPtr 2273 * (e.g. "a") contains a sequence of child namespaces (e.g. "b") 2274 * such that there is a identically-named sequence of child namespaces 2275 * starting from :: (e.g. "::b") whose tail namespace contains a command 2276 * also named cmdName. 2277 */ 2278 2279 cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr); 2280 for (nsPtr = newCmdPtr->nsPtr; 2281 (nsPtr != NULL) && (nsPtr != globalNsPtr); 2282 nsPtr = nsPtr->parentPtr) { 2283 /* 2284 * Find the maximal sequence of child namespaces contained in nsPtr 2285 * such that there is a identically-named sequence of child 2286 * namespaces starting from ::. shadowNsPtr will be the tail of this 2287 * sequence, or the deepest namespace under :: that might contain a 2288 * command now shadowed by cmdName. We check below if shadowNsPtr 2289 * actually contains a command cmdName. 2290 */ 2291 2292 found = 1; 2293 shadowNsPtr = globalNsPtr; 2294 2295 for (i = trailFront; i >= 0; i--) { 2296 trailNsPtr = trailPtr[i]; 2297 hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable, 2298 trailNsPtr->name); 2299 if (hPtr != NULL) { 2300 shadowNsPtr = (Namespace *) Tcl_GetHashValue(hPtr); 2301 } else { 2302 found = 0; 2303 break; 2304 } 2305 } 2306 2307 /* 2308 * If shadowNsPtr contains a command named cmdName, we invalidate 2309 * all of the command refs cached in nsPtr. As a boundary case, 2310 * shadowNsPtr is initially :: and we check for case 1. above. 2311 */ 2312 2313 if (found) { 2314 hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName); 2315 if (hPtr != NULL) { 2316 nsPtr->cmdRefEpoch++; 2317 2318 /* 2319 * If the shadowed command was compiled to bytecodes, we 2320 * invalidate all the bytecodes in nsPtr, to force a new 2321 * compilation. We use the resolverEpoch to signal the need 2322 * for a fresh compilation of every bytecode. 2323 */ 2324 2325 if ((((Command *) Tcl_GetHashValue(hPtr))->compileProc) != NULL) { 2326 nsPtr->resolverEpoch++; 2327 } 2328 } 2329 } 2330 2331 /* 2332 * Insert nsPtr at the front of the trail list: i.e., at the end 2333 * of the trailPtr array. 2334 */ 2335 2336 trailFront++; 2337 if (trailFront == trailSize) { 2338 size_t currBytes = trailSize * sizeof(Namespace *); 2339 int newSize = 2*trailSize; 2340 size_t newBytes = newSize * sizeof(Namespace *); 2341 Namespace **newPtr = 2342 (Namespace **) ckalloc((unsigned) newBytes); 2343 2344 memcpy((VOID *) newPtr, (VOID *) trailPtr, currBytes); 2345 if (trailPtr != trailStorage) { 2346 ckfree((char *) trailPtr); 2347 } 2348 trailPtr = newPtr; 2349 trailSize = newSize; 2350 } 2351 trailPtr[trailFront] = nsPtr; 2352 } 2353 2354 /* 2355 * Free any allocated storage. 2356 */ 2357 2358 if (trailPtr != trailStorage) { 2359 ckfree((char *) trailPtr); 2360 } 2361} 2362 2363/* 2364 *---------------------------------------------------------------------- 2365 * 2366 * GetNamespaceFromObj -- 2367 * 2368 * Gets the namespace specified by the name in a Tcl_Obj. 2369 * 2370 * Results: 2371 * Returns TCL_OK if the namespace was resolved successfully, and 2372 * stores a pointer to the namespace in the location specified by 2373 * nsPtrPtr. If the namespace can't be found, the procedure stores 2374 * NULL in *nsPtrPtr and returns TCL_OK. If anything else goes wrong, 2375 * this procedure returns TCL_ERROR. 2376 * 2377 * Side effects: 2378 * May update the internal representation for the object, caching the 2379 * namespace reference. The next time this procedure is called, the 2380 * namespace value can be found quickly. 2381 * 2382 * If anything goes wrong, an error message is left in the 2383 * interpreter's result object. 2384 * 2385 *---------------------------------------------------------------------- 2386 */ 2387 2388static int 2389GetNamespaceFromObj(interp, objPtr, nsPtrPtr) 2390 Tcl_Interp *interp; /* The current interpreter. */ 2391 Tcl_Obj *objPtr; /* The object to be resolved as the name 2392 * of a namespace. */ 2393 Tcl_Namespace **nsPtrPtr; /* Result namespace pointer goes here. */ 2394{ 2395 Interp *iPtr = (Interp *) interp; 2396 register ResolvedNsName *resNamePtr; 2397 register Namespace *nsPtr; 2398 Namespace *currNsPtr; 2399 CallFrame *savedFramePtr; 2400 int result = TCL_OK; 2401 char *name; 2402 2403 /* 2404 * If the namespace name is fully qualified, do as if the lookup were 2405 * done from the global namespace; this helps avoid repeated lookups 2406 * of fully qualified names. 2407 */ 2408 2409 savedFramePtr = iPtr->varFramePtr; 2410 name = Tcl_GetString(objPtr); 2411 if ((*name++ == ':') && (*name == ':')) { 2412 iPtr->varFramePtr = NULL; 2413 } 2414 2415 currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2416 2417 /* 2418 * Get the internal representation, converting to a namespace type if 2419 * needed. The internal representation is a ResolvedNsName that points 2420 * to the actual namespace. 2421 */ 2422 2423 if (objPtr->typePtr != &tclNsNameType) { 2424 result = tclNsNameType.setFromAnyProc(interp, objPtr); 2425 if (result != TCL_OK) { 2426 goto done; 2427 } 2428 } 2429 resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; 2430 2431 /* 2432 * Check the context namespace of the resolved symbol to make sure that 2433 * it is fresh. If not, then force another conversion to the namespace 2434 * type, to discard the old rep and create a new one. Note that we 2435 * verify that the namespace id of the cached namespace is the same as 2436 * the id when we cached it; this insures that the namespace wasn't 2437 * deleted and a new one created at the same address. 2438 */ 2439 2440 nsPtr = NULL; 2441 if ((resNamePtr != NULL) 2442 && (resNamePtr->refNsPtr == currNsPtr) 2443 && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { 2444 nsPtr = resNamePtr->nsPtr; 2445 if (nsPtr->flags & NS_DEAD) { 2446 nsPtr = NULL; 2447 } 2448 } 2449 if (nsPtr == NULL) { /* try again */ 2450 result = tclNsNameType.setFromAnyProc(interp, objPtr); 2451 if (result != TCL_OK) { 2452 goto done; 2453 } 2454 resNamePtr = (ResolvedNsName *) objPtr->internalRep.otherValuePtr; 2455 if (resNamePtr != NULL) { 2456 nsPtr = resNamePtr->nsPtr; 2457 if (nsPtr->flags & NS_DEAD) { 2458 nsPtr = NULL; 2459 } 2460 } 2461 } 2462 *nsPtrPtr = (Tcl_Namespace *) nsPtr; 2463 2464 done: 2465 iPtr->varFramePtr = savedFramePtr; 2466 return result; 2467} 2468 2469/* 2470 *---------------------------------------------------------------------- 2471 * 2472 * Tcl_NamespaceObjCmd -- 2473 * 2474 * Invoked to implement the "namespace" command that creates, deletes, 2475 * or manipulates Tcl namespaces. Handles the following syntax: 2476 * 2477 * namespace children ?name? ?pattern? 2478 * namespace code arg 2479 * namespace current 2480 * namespace delete ?name name...? 2481 * namespace eval name arg ?arg...? 2482 * namespace exists name 2483 * namespace export ?-clear? ?pattern pattern...? 2484 * namespace forget ?pattern pattern...? 2485 * namespace import ?-force? ?pattern pattern...? 2486 * namespace inscope name arg ?arg...? 2487 * namespace origin name 2488 * namespace parent ?name? 2489 * namespace qualifiers string 2490 * namespace tail string 2491 * namespace which ?-command? ?-variable? name 2492 * 2493 * Results: 2494 * Returns TCL_OK if the command is successful. Returns TCL_ERROR if 2495 * anything goes wrong. 2496 * 2497 * Side effects: 2498 * Based on the subcommand name (e.g., "import"), this procedure 2499 * dispatches to a corresponding procedure NamespaceXXXCmd defined 2500 * statically in this file. This procedure's side effects depend on 2501 * whatever that subcommand procedure does. If there is an error, this 2502 * procedure returns an error message in the interpreter's result 2503 * object. Otherwise it may return a result in the interpreter's result 2504 * object. 2505 * 2506 *---------------------------------------------------------------------- 2507 */ 2508 2509int 2510Tcl_NamespaceObjCmd(clientData, interp, objc, objv) 2511 ClientData clientData; /* Arbitrary value passed to cmd. */ 2512 Tcl_Interp *interp; /* Current interpreter. */ 2513 register int objc; /* Number of arguments. */ 2514 register Tcl_Obj *CONST objv[]; /* Argument objects. */ 2515{ 2516 static CONST char *subCmds[] = { 2517 "children", "code", "current", "delete", 2518 "eval", "exists", "export", "forget", "import", 2519 "inscope", "origin", "parent", "qualifiers", 2520 "tail", "which", (char *) NULL 2521 }; 2522 enum NSSubCmdIdx { 2523 NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, 2524 NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx, 2525 NSInscopeIdx, NSOriginIdx, NSParentIdx, NSQualifiersIdx, 2526 NSTailIdx, NSWhichIdx 2527 }; 2528 int index, result; 2529 2530 if (objc < 2) { 2531 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?"); 2532 return TCL_ERROR; 2533 } 2534 2535 /* 2536 * Return an index reflecting the particular subcommand. 2537 */ 2538 2539 result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds, 2540 "option", /*flags*/ 0, (int *) &index); 2541 if (result != TCL_OK) { 2542 return result; 2543 } 2544 2545 switch (index) { 2546 case NSChildrenIdx: 2547 result = NamespaceChildrenCmd(clientData, interp, objc, objv); 2548 break; 2549 case NSCodeIdx: 2550 result = NamespaceCodeCmd(clientData, interp, objc, objv); 2551 break; 2552 case NSCurrentIdx: 2553 result = NamespaceCurrentCmd(clientData, interp, objc, objv); 2554 break; 2555 case NSDeleteIdx: 2556 result = NamespaceDeleteCmd(clientData, interp, objc, objv); 2557 break; 2558 case NSEvalIdx: 2559 result = NamespaceEvalCmd(clientData, interp, objc, objv); 2560 break; 2561 case NSExistsIdx: 2562 result = NamespaceExistsCmd(clientData, interp, objc, objv); 2563 break; 2564 case NSExportIdx: 2565 result = NamespaceExportCmd(clientData, interp, objc, objv); 2566 break; 2567 case NSForgetIdx: 2568 result = NamespaceForgetCmd(clientData, interp, objc, objv); 2569 break; 2570 case NSImportIdx: 2571 result = NamespaceImportCmd(clientData, interp, objc, objv); 2572 break; 2573 case NSInscopeIdx: 2574 result = NamespaceInscopeCmd(clientData, interp, objc, objv); 2575 break; 2576 case NSOriginIdx: 2577 result = NamespaceOriginCmd(clientData, interp, objc, objv); 2578 break; 2579 case NSParentIdx: 2580 result = NamespaceParentCmd(clientData, interp, objc, objv); 2581 break; 2582 case NSQualifiersIdx: 2583 result = NamespaceQualifiersCmd(clientData, interp, objc, objv); 2584 break; 2585 case NSTailIdx: 2586 result = NamespaceTailCmd(clientData, interp, objc, objv); 2587 break; 2588 case NSWhichIdx: 2589 result = NamespaceWhichCmd(clientData, interp, objc, objv); 2590 break; 2591 } 2592 return result; 2593} 2594 2595/* 2596 *---------------------------------------------------------------------- 2597 * 2598 * NamespaceChildrenCmd -- 2599 * 2600 * Invoked to implement the "namespace children" command that returns a 2601 * list containing the fully-qualified names of the child namespaces of 2602 * a given namespace. Handles the following syntax: 2603 * 2604 * namespace children ?name? ?pattern? 2605 * 2606 * Results: 2607 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2608 * 2609 * Side effects: 2610 * Returns a result in the interpreter's result object. If anything 2611 * goes wrong, the result is an error message. 2612 * 2613 *---------------------------------------------------------------------- 2614 */ 2615 2616static int 2617NamespaceChildrenCmd(dummy, interp, objc, objv) 2618 ClientData dummy; /* Not used. */ 2619 Tcl_Interp *interp; /* Current interpreter. */ 2620 int objc; /* Number of arguments. */ 2621 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2622{ 2623 Tcl_Namespace *namespacePtr; 2624 Namespace *nsPtr, *childNsPtr; 2625 Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); 2626 char *pattern = NULL; 2627 Tcl_DString buffer; 2628 register Tcl_HashEntry *entryPtr; 2629 Tcl_HashSearch search; 2630 Tcl_Obj *listPtr, *elemPtr; 2631 2632 /* 2633 * Get a pointer to the specified namespace, or the current namespace. 2634 */ 2635 2636 if (objc == 2) { 2637 nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2638 } else if ((objc == 3) || (objc == 4)) { 2639 if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { 2640 return TCL_ERROR; 2641 } 2642 if (namespacePtr == NULL) { 2643 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2644 "unknown namespace \"", Tcl_GetString(objv[2]), 2645 "\" in namespace children command", (char *) NULL); 2646 return TCL_ERROR; 2647 } 2648 nsPtr = (Namespace *) namespacePtr; 2649 } else { 2650 Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?"); 2651 return TCL_ERROR; 2652 } 2653 2654 /* 2655 * Get the glob-style pattern, if any, used to narrow the search. 2656 */ 2657 2658 Tcl_DStringInit(&buffer); 2659 if (objc == 4) { 2660 char *name = Tcl_GetString(objv[3]); 2661 2662 if ((*name == ':') && (*(name+1) == ':')) { 2663 pattern = name; 2664 } else { 2665 Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); 2666 if (nsPtr != globalNsPtr) { 2667 Tcl_DStringAppend(&buffer, "::", 2); 2668 } 2669 Tcl_DStringAppend(&buffer, name, -1); 2670 pattern = Tcl_DStringValue(&buffer); 2671 } 2672 } 2673 2674 /* 2675 * Create a list containing the full names of all child namespaces 2676 * whose names match the specified pattern, if any. 2677 */ 2678 2679 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 2680 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search); 2681 while (entryPtr != NULL) { 2682 childNsPtr = (Namespace *) Tcl_GetHashValue(entryPtr); 2683 if ((pattern == NULL) 2684 || Tcl_StringMatch(childNsPtr->fullName, pattern)) { 2685 elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1); 2686 Tcl_ListObjAppendElement(interp, listPtr, elemPtr); 2687 } 2688 entryPtr = Tcl_NextHashEntry(&search); 2689 } 2690 2691 Tcl_SetObjResult(interp, listPtr); 2692 Tcl_DStringFree(&buffer); 2693 return TCL_OK; 2694} 2695 2696/* 2697 *---------------------------------------------------------------------- 2698 * 2699 * NamespaceCodeCmd -- 2700 * 2701 * Invoked to implement the "namespace code" command to capture the 2702 * namespace context of a command. Handles the following syntax: 2703 * 2704 * namespace code arg 2705 * 2706 * Here "arg" can be a list. "namespace code arg" produces a result 2707 * equivalent to that produced by the command 2708 * 2709 * list ::namespace inscope [namespace current] $arg 2710 * 2711 * However, if "arg" is itself a scoped value starting with 2712 * "::namespace inscope", then the result is just "arg". 2713 * 2714 * Results: 2715 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2716 * 2717 * Side effects: 2718 * If anything goes wrong, this procedure returns an error 2719 * message as the result in the interpreter's result object. 2720 * 2721 *---------------------------------------------------------------------- 2722 */ 2723 2724static int 2725NamespaceCodeCmd(dummy, interp, objc, objv) 2726 ClientData dummy; /* Not used. */ 2727 Tcl_Interp *interp; /* Current interpreter. */ 2728 int objc; /* Number of arguments. */ 2729 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2730{ 2731 Namespace *currNsPtr; 2732 Tcl_Obj *listPtr, *objPtr; 2733 register char *arg, *p; 2734 int length; 2735 2736 if (objc != 3) { 2737 Tcl_WrongNumArgs(interp, 2, objv, "arg"); 2738 return TCL_ERROR; 2739 } 2740 2741 /* 2742 * If "arg" is already a scoped value, then return it directly. 2743 */ 2744 2745 arg = Tcl_GetStringFromObj(objv[2], &length); 2746 while (*arg == ':') { 2747 arg++; 2748 length--; 2749 } 2750 if ((*arg == 'n') && (length > 17) 2751 && (strncmp(arg, "namespace", 9) == 0)) { 2752 for (p = (arg + 9); (*p == ' '); p++) { 2753 /* empty body: skip over spaces */ 2754 } 2755 if ((*p == 'i') && ((p + 7) <= (arg + length)) 2756 && (strncmp(p, "inscope", 7) == 0)) { 2757 Tcl_SetObjResult(interp, objv[2]); 2758 return TCL_OK; 2759 } 2760 } 2761 2762 /* 2763 * Otherwise, construct a scoped command by building a list with 2764 * "namespace inscope", the full name of the current namespace, and 2765 * the argument "arg". By constructing a list, we ensure that scoped 2766 * commands are interpreted properly when they are executed later, 2767 * by the "namespace inscope" command. 2768 */ 2769 2770 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 2771 Tcl_ListObjAppendElement(interp, listPtr, 2772 Tcl_NewStringObj("::namespace", -1)); 2773 Tcl_ListObjAppendElement(interp, listPtr, 2774 Tcl_NewStringObj("inscope", -1)); 2775 2776 currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2777 if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { 2778 objPtr = Tcl_NewStringObj("::", -1); 2779 } else { 2780 objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1); 2781 } 2782 Tcl_ListObjAppendElement(interp, listPtr, objPtr); 2783 2784 Tcl_ListObjAppendElement(interp, listPtr, objv[2]); 2785 2786 Tcl_SetObjResult(interp, listPtr); 2787 return TCL_OK; 2788} 2789 2790/* 2791 *---------------------------------------------------------------------- 2792 * 2793 * NamespaceCurrentCmd -- 2794 * 2795 * Invoked to implement the "namespace current" command which returns 2796 * the fully-qualified name of the current namespace. Handles the 2797 * following syntax: 2798 * 2799 * namespace current 2800 * 2801 * Results: 2802 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2803 * 2804 * Side effects: 2805 * Returns a result in the interpreter's result object. If anything 2806 * goes wrong, the result is an error message. 2807 * 2808 *---------------------------------------------------------------------- 2809 */ 2810 2811static int 2812NamespaceCurrentCmd(dummy, interp, objc, objv) 2813 ClientData dummy; /* Not used. */ 2814 Tcl_Interp *interp; /* Current interpreter. */ 2815 int objc; /* Number of arguments. */ 2816 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2817{ 2818 register Namespace *currNsPtr; 2819 2820 if (objc != 2) { 2821 Tcl_WrongNumArgs(interp, 2, objv, NULL); 2822 return TCL_ERROR; 2823 } 2824 2825 /* 2826 * The "real" name of the global namespace ("::") is the null string, 2827 * but we return "::" for it as a convenience to programmers. Note that 2828 * "" and "::" are treated as synonyms by the namespace code so that it 2829 * is still easy to do things like: 2830 * 2831 * namespace [namespace current]::bar { ... } 2832 */ 2833 2834 currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); 2835 if (currNsPtr == (Namespace *) Tcl_GetGlobalNamespace(interp)) { 2836 Tcl_AppendToObj(Tcl_GetObjResult(interp), "::", -1); 2837 } else { 2838 Tcl_AppendToObj(Tcl_GetObjResult(interp), currNsPtr->fullName, -1); 2839 } 2840 return TCL_OK; 2841} 2842 2843/* 2844 *---------------------------------------------------------------------- 2845 * 2846 * NamespaceDeleteCmd -- 2847 * 2848 * Invoked to implement the "namespace delete" command to delete 2849 * namespace(s). Handles the following syntax: 2850 * 2851 * namespace delete ?name name...? 2852 * 2853 * Each name identifies a namespace. It may include a sequence of 2854 * namespace qualifiers separated by "::"s. If a namespace is found, it 2855 * is deleted: all variables and procedures contained in that namespace 2856 * are deleted. If that namespace is being used on the call stack, it 2857 * is kept alive (but logically deleted) until it is removed from the 2858 * call stack: that is, it can no longer be referenced by name but any 2859 * currently executing procedure that refers to it is allowed to do so 2860 * until the procedure returns. If the namespace can't be found, this 2861 * procedure returns an error. If no namespaces are specified, this 2862 * command does nothing. 2863 * 2864 * Results: 2865 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 2866 * 2867 * Side effects: 2868 * Deletes the specified namespaces. If anything goes wrong, this 2869 * procedure returns an error message in the interpreter's 2870 * result object. 2871 * 2872 *---------------------------------------------------------------------- 2873 */ 2874 2875static int 2876NamespaceDeleteCmd(dummy, interp, objc, objv) 2877 ClientData dummy; /* Not used. */ 2878 Tcl_Interp *interp; /* Current interpreter. */ 2879 int objc; /* Number of arguments. */ 2880 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2881{ 2882 Tcl_Namespace *namespacePtr; 2883 char *name; 2884 register int i; 2885 2886 if (objc < 2) { 2887 Tcl_WrongNumArgs(interp, 2, objv, "?name name...?"); 2888 return TCL_ERROR; 2889 } 2890 2891 /* 2892 * Destroying one namespace may cause another to be destroyed. Break 2893 * this into two passes: first check to make sure that all namespaces on 2894 * the command line are valid, and report any errors. 2895 */ 2896 2897 for (i = 2; i < objc; i++) { 2898 name = Tcl_GetString(objv[i]); 2899 namespacePtr = Tcl_FindNamespace(interp, name, 2900 (Tcl_Namespace *) NULL, /*flags*/ 0); 2901 if (namespacePtr == NULL) { 2902 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 2903 "unknown namespace \"", Tcl_GetString(objv[i]), 2904 "\" in namespace delete command", (char *) NULL); 2905 return TCL_ERROR; 2906 } 2907 } 2908 2909 /* 2910 * Okay, now delete each namespace. 2911 */ 2912 2913 for (i = 2; i < objc; i++) { 2914 name = Tcl_GetString(objv[i]); 2915 namespacePtr = Tcl_FindNamespace(interp, name, 2916 (Tcl_Namespace *) NULL, /* flags */ 0); 2917 if (namespacePtr) { 2918 Tcl_DeleteNamespace(namespacePtr); 2919 } 2920 } 2921 return TCL_OK; 2922} 2923 2924/* 2925 *---------------------------------------------------------------------- 2926 * 2927 * NamespaceEvalCmd -- 2928 * 2929 * Invoked to implement the "namespace eval" command. Executes 2930 * commands in a namespace. If the namespace does not already exist, 2931 * it is created. Handles the following syntax: 2932 * 2933 * namespace eval name arg ?arg...? 2934 * 2935 * If more than one arg argument is specified, the command that is 2936 * executed is the result of concatenating the arguments together with 2937 * a space between each argument. 2938 * 2939 * Results: 2940 * Returns TCL_OK if the namespace is found and the commands are 2941 * executed successfully. Returns TCL_ERROR if anything goes wrong. 2942 * 2943 * Side effects: 2944 * Returns the result of the command in the interpreter's result 2945 * object. If anything goes wrong, this procedure returns an error 2946 * message as the result. 2947 * 2948 *---------------------------------------------------------------------- 2949 */ 2950 2951static int 2952NamespaceEvalCmd(dummy, interp, objc, objv) 2953 ClientData dummy; /* Not used. */ 2954 Tcl_Interp *interp; /* Current interpreter. */ 2955 int objc; /* Number of arguments. */ 2956 Tcl_Obj *CONST objv[]; /* Argument objects. */ 2957{ 2958 Tcl_Namespace *namespacePtr; 2959 CallFrame frame; 2960 Tcl_Obj *objPtr; 2961 char *name; 2962 int length, result; 2963 2964 if (objc < 4) { 2965 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); 2966 return TCL_ERROR; 2967 } 2968 2969 /* 2970 * Try to resolve the namespace reference, caching the result in the 2971 * namespace object along the way. 2972 */ 2973 2974 result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); 2975 if (result != TCL_OK) { 2976 return result; 2977 } 2978 2979 /* 2980 * If the namespace wasn't found, try to create it. 2981 */ 2982 2983 if (namespacePtr == NULL) { 2984 name = Tcl_GetStringFromObj(objv[2], &length); 2985 namespacePtr = Tcl_CreateNamespace(interp, name, (ClientData) NULL, 2986 (Tcl_NamespaceDeleteProc *) NULL); 2987 if (namespacePtr == NULL) { 2988 return TCL_ERROR; 2989 } 2990 } 2991 2992 /* 2993 * Make the specified namespace the current namespace and evaluate 2994 * the command(s). 2995 */ 2996 2997 result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) &frame, 2998 namespacePtr, /*isProcCallFrame*/ 0); 2999 if (result != TCL_OK) { 3000 return TCL_ERROR; 3001 } 3002 frame.objc = objc; 3003 frame.objv = objv; /* ref counts do not need to be incremented here */ 3004 3005 if (objc == 4) { 3006#ifndef TCL_TIP280 3007 result = Tcl_EvalObjEx(interp, objv[3], 0); 3008#else 3009 /* TIP #280 : Make actual argument location available to eval'd script */ 3010 Interp* iPtr = (Interp*) interp; 3011 CmdFrame* invoker = iPtr->cmdFramePtr; 3012 int word = 3; 3013 TclArgumentGet (interp, objv[3], &invoker, &word); 3014 result = TclEvalObjEx(interp, objv[3], 0, invoker, word); 3015#endif 3016 } else { 3017 /* 3018 * More than one argument: concatenate them together with spaces 3019 * between, then evaluate the result. Tcl_EvalObjEx will delete 3020 * the object when it decrements its refcount after eval'ing it. 3021 */ 3022 objPtr = Tcl_ConcatObj(objc-3, objv+3); 3023#ifndef TCL_TIP280 3024 result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); 3025#else 3026 /* TIP #280. Make invoking context available to eval'd script */ 3027 result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0); 3028#endif 3029 } 3030 if (result == TCL_ERROR) { 3031 char msg[256 + TCL_INTEGER_SPACE]; 3032 3033 sprintf(msg, "\n (in namespace eval \"%.200s\" script line %d)", 3034 namespacePtr->fullName, interp->errorLine); 3035 Tcl_AddObjErrorInfo(interp, msg, -1); 3036 } 3037 3038 /* 3039 * Restore the previous "current" namespace. 3040 */ 3041 3042 Tcl_PopCallFrame(interp); 3043 return result; 3044} 3045 3046/* 3047 *---------------------------------------------------------------------- 3048 * 3049 * NamespaceExistsCmd -- 3050 * 3051 * Invoked to implement the "namespace exists" command that returns 3052 * true if the given namespace currently exists, and false otherwise. 3053 * Handles the following syntax: 3054 * 3055 * namespace exists name 3056 * 3057 * Results: 3058 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3059 * 3060 * Side effects: 3061 * Returns a result in the interpreter's result object. If anything 3062 * goes wrong, the result is an error message. 3063 * 3064 *---------------------------------------------------------------------- 3065 */ 3066 3067static int 3068NamespaceExistsCmd(dummy, interp, objc, objv) 3069 ClientData dummy; /* Not used. */ 3070 Tcl_Interp *interp; /* Current interpreter. */ 3071 int objc; /* Number of arguments. */ 3072 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3073{ 3074 Tcl_Namespace *namespacePtr; 3075 3076 if (objc != 3) { 3077 Tcl_WrongNumArgs(interp, 2, objv, "name"); 3078 return TCL_ERROR; 3079 } 3080 3081 /* 3082 * Check whether the given namespace exists 3083 */ 3084 3085 if (GetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) { 3086 return TCL_ERROR; 3087 } 3088 3089 Tcl_SetBooleanObj(Tcl_GetObjResult(interp), (namespacePtr != NULL)); 3090 return TCL_OK; 3091} 3092 3093/* 3094 *---------------------------------------------------------------------- 3095 * 3096 * NamespaceExportCmd -- 3097 * 3098 * Invoked to implement the "namespace export" command that specifies 3099 * which commands are exported from a namespace. The exported commands 3100 * are those that can be imported into another namespace using 3101 * "namespace import". Both commands defined in a namespace and 3102 * commands the namespace has imported can be exported by a 3103 * namespace. This command has the following syntax: 3104 * 3105 * namespace export ?-clear? ?pattern pattern...? 3106 * 3107 * Each pattern may contain "string match"-style pattern matching 3108 * special characters, but the pattern may not include any namespace 3109 * qualifiers: that is, the pattern must specify commands in the 3110 * current (exporting) namespace. The specified patterns are appended 3111 * onto the namespace's list of export patterns. 3112 * 3113 * To reset the namespace's export pattern list, specify the "-clear" 3114 * flag. 3115 * 3116 * If there are no export patterns and the "-clear" flag isn't given, 3117 * this command returns the namespace's current export list. 3118 * 3119 * Results: 3120 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3121 * 3122 * Side effects: 3123 * Returns a result in the interpreter's result object. If anything 3124 * goes wrong, the result is an error message. 3125 * 3126 *---------------------------------------------------------------------- 3127 */ 3128 3129static int 3130NamespaceExportCmd(dummy, interp, objc, objv) 3131 ClientData dummy; /* Not used. */ 3132 Tcl_Interp *interp; /* Current interpreter. */ 3133 int objc; /* Number of arguments. */ 3134 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3135{ 3136 Namespace *currNsPtr = (Namespace*) Tcl_GetCurrentNamespace(interp); 3137 char *pattern, *string; 3138 int resetListFirst = 0; 3139 int firstArg, patternCt, i, result; 3140 3141 if (objc < 2) { 3142 Tcl_WrongNumArgs(interp, 2, objv, 3143 "?-clear? ?pattern pattern...?"); 3144 return TCL_ERROR; 3145 } 3146 3147 /* 3148 * Process the optional "-clear" argument. 3149 */ 3150 3151 firstArg = 2; 3152 if (firstArg < objc) { 3153 string = Tcl_GetString(objv[firstArg]); 3154 if (strcmp(string, "-clear") == 0) { 3155 resetListFirst = 1; 3156 firstArg++; 3157 } 3158 } 3159 3160 /* 3161 * If no pattern arguments are given, and "-clear" isn't specified, 3162 * return the namespace's current export pattern list. 3163 */ 3164 3165 patternCt = (objc - firstArg); 3166 if (patternCt == 0) { 3167 if (firstArg > 2) { 3168 return TCL_OK; 3169 } else { /* create list with export patterns */ 3170 Tcl_Obj *listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3171 result = Tcl_AppendExportList(interp, 3172 (Tcl_Namespace *) currNsPtr, listPtr); 3173 if (result != TCL_OK) { 3174 return result; 3175 } 3176 Tcl_SetObjResult(interp, listPtr); 3177 return TCL_OK; 3178 } 3179 } 3180 3181 /* 3182 * Add each pattern to the namespace's export pattern list. 3183 */ 3184 3185 for (i = firstArg; i < objc; i++) { 3186 pattern = Tcl_GetString(objv[i]); 3187 result = Tcl_Export(interp, (Tcl_Namespace *) currNsPtr, pattern, 3188 ((i == firstArg)? resetListFirst : 0)); 3189 if (result != TCL_OK) { 3190 return result; 3191 } 3192 } 3193 return TCL_OK; 3194} 3195 3196/* 3197 *---------------------------------------------------------------------- 3198 * 3199 * NamespaceForgetCmd -- 3200 * 3201 * Invoked to implement the "namespace forget" command to remove 3202 * imported commands from a namespace. Handles the following syntax: 3203 * 3204 * namespace forget ?pattern pattern...? 3205 * 3206 * Each pattern is a name like "foo::*" or "a::b::x*". That is, the 3207 * pattern may include the special pattern matching characters 3208 * recognized by the "string match" command, but only in the command 3209 * name at the end of the qualified name; the special pattern 3210 * characters may not appear in a namespace name. All of the commands 3211 * that match that pattern are checked to see if they have an imported 3212 * command in the current namespace that refers to the matched 3213 * command. If there is an alias, it is removed. 3214 * 3215 * Results: 3216 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3217 * 3218 * Side effects: 3219 * Imported commands are removed from the current namespace. If 3220 * anything goes wrong, this procedure returns an error message in the 3221 * interpreter's result object. 3222 * 3223 *---------------------------------------------------------------------- 3224 */ 3225 3226static int 3227NamespaceForgetCmd(dummy, interp, objc, objv) 3228 ClientData dummy; /* Not used. */ 3229 Tcl_Interp *interp; /* Current interpreter. */ 3230 int objc; /* Number of arguments. */ 3231 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3232{ 3233 char *pattern; 3234 register int i, result; 3235 3236 if (objc < 2) { 3237 Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?"); 3238 return TCL_ERROR; 3239 } 3240 3241 for (i = 2; i < objc; i++) { 3242 pattern = Tcl_GetString(objv[i]); 3243 result = Tcl_ForgetImport(interp, (Tcl_Namespace *) NULL, pattern); 3244 if (result != TCL_OK) { 3245 return result; 3246 } 3247 } 3248 return TCL_OK; 3249} 3250 3251/* 3252 *---------------------------------------------------------------------- 3253 * 3254 * NamespaceImportCmd -- 3255 * 3256 * Invoked to implement the "namespace import" command that imports 3257 * commands into a namespace. Handles the following syntax: 3258 * 3259 * namespace import ?-force? ?pattern pattern...? 3260 * 3261 * Each pattern is a namespace-qualified name like "foo::*", 3262 * "a::b::x*", or "bar::p". That is, the pattern may include the 3263 * special pattern matching characters recognized by the "string match" 3264 * command, but only in the command name at the end of the qualified 3265 * name; the special pattern characters may not appear in a namespace 3266 * name. All of the commands that match the pattern and which are 3267 * exported from their namespace are made accessible from the current 3268 * namespace context. This is done by creating a new "imported command" 3269 * in the current namespace that points to the real command in its 3270 * original namespace; when the imported command is called, it invokes 3271 * the real command. 3272 * 3273 * If an imported command conflicts with an existing command, it is 3274 * treated as an error. But if the "-force" option is included, then 3275 * existing commands are overwritten by the imported commands. 3276 * 3277 * Results: 3278 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3279 * 3280 * Side effects: 3281 * Adds imported commands to the current namespace. If anything goes 3282 * wrong, this procedure returns an error message in the interpreter's 3283 * result object. 3284 * 3285 *---------------------------------------------------------------------- 3286 */ 3287 3288static int 3289NamespaceImportCmd(dummy, interp, objc, objv) 3290 ClientData dummy; /* Not used. */ 3291 Tcl_Interp *interp; /* Current interpreter. */ 3292 int objc; /* Number of arguments. */ 3293 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3294{ 3295 int allowOverwrite = 0; 3296 char *string, *pattern; 3297 register int i, result; 3298 int firstArg; 3299 3300 if (objc < 2) { 3301 Tcl_WrongNumArgs(interp, 2, objv, 3302 "?-force? ?pattern pattern...?"); 3303 return TCL_ERROR; 3304 } 3305 3306 /* 3307 * Skip over the optional "-force" as the first argument. 3308 */ 3309 3310 firstArg = 2; 3311 if (firstArg < objc) { 3312 string = Tcl_GetString(objv[firstArg]); 3313 if ((*string == '-') && (strcmp(string, "-force") == 0)) { 3314 allowOverwrite = 1; 3315 firstArg++; 3316 } 3317 } 3318 3319 /* 3320 * Handle the imports for each of the patterns. 3321 */ 3322 3323 for (i = firstArg; i < objc; i++) { 3324 pattern = Tcl_GetString(objv[i]); 3325 result = Tcl_Import(interp, (Tcl_Namespace *) NULL, pattern, 3326 allowOverwrite); 3327 if (result != TCL_OK) { 3328 return result; 3329 } 3330 } 3331 return TCL_OK; 3332} 3333 3334/* 3335 *---------------------------------------------------------------------- 3336 * 3337 * NamespaceInscopeCmd -- 3338 * 3339 * Invoked to implement the "namespace inscope" command that executes a 3340 * script in the context of a particular namespace. This command is not 3341 * expected to be used directly by programmers; calls to it are 3342 * generated implicitly when programs use "namespace code" commands 3343 * to register callback scripts. Handles the following syntax: 3344 * 3345 * namespace inscope name arg ?arg...? 3346 * 3347 * The "namespace inscope" command is much like the "namespace eval" 3348 * command except that it has lappend semantics and the namespace must 3349 * already exist. It treats the first argument as a list, and appends 3350 * any arguments after the first onto the end as proper list elements. 3351 * For example, 3352 * 3353 * namespace inscope ::foo a b c d 3354 * 3355 * is equivalent to 3356 * 3357 * namespace eval ::foo [concat a [list b c d]] 3358 * 3359 * This lappend semantics is important because many callback scripts 3360 * are actually prefixes. 3361 * 3362 * Results: 3363 * Returns TCL_OK to indicate success, or TCL_ERROR to indicate 3364 * failure. 3365 * 3366 * Side effects: 3367 * Returns a result in the Tcl interpreter's result object. 3368 * 3369 *---------------------------------------------------------------------- 3370 */ 3371 3372static int 3373NamespaceInscopeCmd(dummy, interp, objc, objv) 3374 ClientData dummy; /* Not used. */ 3375 Tcl_Interp *interp; /* Current interpreter. */ 3376 int objc; /* Number of arguments. */ 3377 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3378{ 3379 Tcl_Namespace *namespacePtr; 3380 Tcl_CallFrame frame; 3381 int i, result; 3382 3383 if (objc < 4) { 3384 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?"); 3385 return TCL_ERROR; 3386 } 3387 3388 /* 3389 * Resolve the namespace reference. 3390 */ 3391 3392 result = GetNamespaceFromObj(interp, objv[2], &namespacePtr); 3393 if (result != TCL_OK) { 3394 return result; 3395 } 3396 if (namespacePtr == NULL) { 3397 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 3398 "unknown namespace \"", Tcl_GetString(objv[2]), 3399 "\" in inscope namespace command", (char *) NULL); 3400 return TCL_ERROR; 3401 } 3402 3403 /* 3404 * Make the specified namespace the current namespace. 3405 */ 3406 3407 result = Tcl_PushCallFrame(interp, &frame, namespacePtr, 3408 /*isProcCallFrame*/ 0); 3409 if (result != TCL_OK) { 3410 return result; 3411 } 3412 3413 /* 3414 * Execute the command. If there is just one argument, just treat it as 3415 * a script and evaluate it. Otherwise, create a list from the arguments 3416 * after the first one, then concatenate the first argument and the list 3417 * of extra arguments to form the command to evaluate. 3418 */ 3419 3420 if (objc == 4) { 3421 result = Tcl_EvalObjEx(interp, objv[3], 0); 3422 } else { 3423 Tcl_Obj *concatObjv[2]; 3424 register Tcl_Obj *listPtr, *cmdObjPtr; 3425 3426 listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); 3427 for (i = 4; i < objc; i++) { 3428 result = Tcl_ListObjAppendElement(interp, listPtr, objv[i]); 3429 if (result != TCL_OK) { 3430 Tcl_DecrRefCount(listPtr); /* free unneeded obj */ 3431 return result; 3432 } 3433 } 3434 3435 concatObjv[0] = objv[3]; 3436 concatObjv[1] = listPtr; 3437 cmdObjPtr = Tcl_ConcatObj(2, concatObjv); 3438 result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT); 3439 Tcl_DecrRefCount(listPtr); /* we're done with the list object */ 3440 } 3441 if (result == TCL_ERROR) { 3442 char msg[256 + TCL_INTEGER_SPACE]; 3443 3444 sprintf(msg, 3445 "\n (in namespace inscope \"%.200s\" script line %d)", 3446 namespacePtr->fullName, interp->errorLine); 3447 Tcl_AddObjErrorInfo(interp, msg, -1); 3448 } 3449 3450 /* 3451 * Restore the previous "current" namespace. 3452 */ 3453 3454 Tcl_PopCallFrame(interp); 3455 return result; 3456} 3457 3458/* 3459 *---------------------------------------------------------------------- 3460 * 3461 * NamespaceOriginCmd -- 3462 * 3463 * Invoked to implement the "namespace origin" command to return the 3464 * fully-qualified name of the "real" command to which the specified 3465 * "imported command" refers. Handles the following syntax: 3466 * 3467 * namespace origin name 3468 * 3469 * Results: 3470 * An imported command is created in an namespace when that namespace 3471 * imports a command from another namespace. If a command is imported 3472 * into a sequence of namespaces a, b,...,n where each successive 3473 * namespace just imports the command from the previous namespace, this 3474 * command returns the fully-qualified name of the original command in 3475 * the first namespace, a. If "name" does not refer to an alias, its 3476 * fully-qualified name is returned. The returned name is stored in the 3477 * interpreter's result object. This procedure returns TCL_OK if 3478 * successful, and TCL_ERROR if anything goes wrong. 3479 * 3480 * Side effects: 3481 * If anything goes wrong, this procedure returns an error message in 3482 * the interpreter's result object. 3483 * 3484 *---------------------------------------------------------------------- 3485 */ 3486 3487static int 3488NamespaceOriginCmd(dummy, interp, objc, objv) 3489 ClientData dummy; /* Not used. */ 3490 Tcl_Interp *interp; /* Current interpreter. */ 3491 int objc; /* Number of arguments. */ 3492 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3493{ 3494 Tcl_Command command, origCommand; 3495 3496 if (objc != 3) { 3497 Tcl_WrongNumArgs(interp, 2, objv, "name"); 3498 return TCL_ERROR; 3499 } 3500 3501 command = Tcl_GetCommandFromObj(interp, objv[2]); 3502 if (command == (Tcl_Command) NULL) { 3503 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 3504 "invalid command name \"", Tcl_GetString(objv[2]), 3505 "\"", (char *) NULL); 3506 return TCL_ERROR; 3507 } 3508 origCommand = TclGetOriginalCommand(command); 3509 if (origCommand == (Tcl_Command) NULL) { 3510 /* 3511 * The specified command isn't an imported command. Return the 3512 * command's name qualified by the full name of the namespace it 3513 * was defined in. 3514 */ 3515 3516 Tcl_GetCommandFullName(interp, command, Tcl_GetObjResult(interp)); 3517 } else { 3518 Tcl_GetCommandFullName(interp, origCommand, Tcl_GetObjResult(interp)); 3519 } 3520 return TCL_OK; 3521} 3522 3523/* 3524 *---------------------------------------------------------------------- 3525 * 3526 * NamespaceParentCmd -- 3527 * 3528 * Invoked to implement the "namespace parent" command that returns the 3529 * fully-qualified name of the parent namespace for a specified 3530 * namespace. Handles the following syntax: 3531 * 3532 * namespace parent ?name? 3533 * 3534 * Results: 3535 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3536 * 3537 * Side effects: 3538 * Returns a result in the interpreter's result object. If anything 3539 * goes wrong, the result is an error message. 3540 * 3541 *---------------------------------------------------------------------- 3542 */ 3543 3544static int 3545NamespaceParentCmd(dummy, interp, objc, objv) 3546 ClientData dummy; /* Not used. */ 3547 Tcl_Interp *interp; /* Current interpreter. */ 3548 int objc; /* Number of arguments. */ 3549 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3550{ 3551 Tcl_Namespace *nsPtr; 3552 int result; 3553 3554 if (objc == 2) { 3555 nsPtr = Tcl_GetCurrentNamespace(interp); 3556 } else if (objc == 3) { 3557 result = GetNamespaceFromObj(interp, objv[2], &nsPtr); 3558 if (result != TCL_OK) { 3559 return result; 3560 } 3561 if (nsPtr == NULL) { 3562 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 3563 "unknown namespace \"", Tcl_GetString(objv[2]), 3564 "\" in namespace parent command", (char *) NULL); 3565 return TCL_ERROR; 3566 } 3567 } else { 3568 Tcl_WrongNumArgs(interp, 2, objv, "?name?"); 3569 return TCL_ERROR; 3570 } 3571 3572 /* 3573 * Report the parent of the specified namespace. 3574 */ 3575 3576 if (nsPtr->parentPtr != NULL) { 3577 Tcl_SetStringObj(Tcl_GetObjResult(interp), 3578 nsPtr->parentPtr->fullName, -1); 3579 } 3580 return TCL_OK; 3581} 3582 3583/* 3584 *---------------------------------------------------------------------- 3585 * 3586 * NamespaceQualifiersCmd -- 3587 * 3588 * Invoked to implement the "namespace qualifiers" command that returns 3589 * any leading namespace qualifiers in a string. These qualifiers are 3590 * namespace names separated by "::"s. For example, for "::foo::p" this 3591 * command returns "::foo", and for "::" it returns "". This command 3592 * is the complement of the "namespace tail" command. Note that this 3593 * command does not check whether the "namespace" names are, in fact, 3594 * the names of currently defined namespaces. Handles the following 3595 * syntax: 3596 * 3597 * namespace qualifiers string 3598 * 3599 * Results: 3600 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3601 * 3602 * Side effects: 3603 * Returns a result in the interpreter's result object. If anything 3604 * goes wrong, the result is an error message. 3605 * 3606 *---------------------------------------------------------------------- 3607 */ 3608 3609static int 3610NamespaceQualifiersCmd(dummy, interp, objc, objv) 3611 ClientData dummy; /* Not used. */ 3612 Tcl_Interp *interp; /* Current interpreter. */ 3613 int objc; /* Number of arguments. */ 3614 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3615{ 3616 register char *name, *p; 3617 int length; 3618 3619 if (objc != 3) { 3620 Tcl_WrongNumArgs(interp, 2, objv, "string"); 3621 return TCL_ERROR; 3622 } 3623 3624 /* 3625 * Find the end of the string, then work backward and find 3626 * the start of the last "::" qualifier. 3627 */ 3628 3629 name = Tcl_GetString(objv[2]); 3630 for (p = name; *p != '\0'; p++) { 3631 /* empty body */ 3632 } 3633 while (--p >= name) { 3634 if ((*p == ':') && (p > name) && (*(p-1) == ':')) { 3635 p -= 2; /* back up over the :: */ 3636 while ((p >= name) && (*p == ':')) { 3637 p--; /* back up over the preceeding : */ 3638 } 3639 break; 3640 } 3641 } 3642 3643 if (p >= name) { 3644 length = p-name+1; 3645 Tcl_AppendToObj(Tcl_GetObjResult(interp), name, length); 3646 } 3647 return TCL_OK; 3648} 3649 3650/* 3651 *---------------------------------------------------------------------- 3652 * 3653 * NamespaceTailCmd -- 3654 * 3655 * Invoked to implement the "namespace tail" command that returns the 3656 * trailing name at the end of a string with "::" namespace 3657 * qualifiers. These qualifiers are namespace names separated by 3658 * "::"s. For example, for "::foo::p" this command returns "p", and for 3659 * "::" it returns "". This command is the complement of the "namespace 3660 * qualifiers" command. Note that this command does not check whether 3661 * the "namespace" names are, in fact, the names of currently defined 3662 * namespaces. Handles the following syntax: 3663 * 3664 * namespace tail string 3665 * 3666 * Results: 3667 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3668 * 3669 * Side effects: 3670 * Returns a result in the interpreter's result object. If anything 3671 * goes wrong, the result is an error message. 3672 * 3673 *---------------------------------------------------------------------- 3674 */ 3675 3676static int 3677NamespaceTailCmd(dummy, interp, objc, objv) 3678 ClientData dummy; /* Not used. */ 3679 Tcl_Interp *interp; /* Current interpreter. */ 3680 int objc; /* Number of arguments. */ 3681 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3682{ 3683 register char *name, *p; 3684 3685 if (objc != 3) { 3686 Tcl_WrongNumArgs(interp, 2, objv, "string"); 3687 return TCL_ERROR; 3688 } 3689 3690 /* 3691 * Find the end of the string, then work backward and find the 3692 * last "::" qualifier. 3693 */ 3694 3695 name = Tcl_GetString(objv[2]); 3696 for (p = name; *p != '\0'; p++) { 3697 /* empty body */ 3698 } 3699 while (--p > name) { 3700 if ((*p == ':') && (*(p-1) == ':')) { 3701 p++; /* just after the last "::" */ 3702 break; 3703 } 3704 } 3705 3706 if (p >= name) { 3707 Tcl_AppendToObj(Tcl_GetObjResult(interp), p, -1); 3708 } 3709 return TCL_OK; 3710} 3711 3712/* 3713 *---------------------------------------------------------------------- 3714 * 3715 * NamespaceWhichCmd -- 3716 * 3717 * Invoked to implement the "namespace which" command that returns the 3718 * fully-qualified name of a command or variable. If the specified 3719 * command or variable does not exist, it returns "". Handles the 3720 * following syntax: 3721 * 3722 * namespace which ?-command? ?-variable? name 3723 * 3724 * Results: 3725 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. 3726 * 3727 * Side effects: 3728 * Returns a result in the interpreter's result object. If anything 3729 * goes wrong, the result is an error message. 3730 * 3731 *---------------------------------------------------------------------- 3732 */ 3733 3734static int 3735NamespaceWhichCmd(dummy, interp, objc, objv) 3736 ClientData dummy; /* Not used. */ 3737 Tcl_Interp *interp; /* Current interpreter. */ 3738 int objc; /* Number of arguments. */ 3739 Tcl_Obj *CONST objv[]; /* Argument objects. */ 3740{ 3741 register char *arg; 3742 Tcl_Command cmd; 3743 Tcl_Var variable; 3744 int argIndex, lookup; 3745 3746 if (objc < 3) { 3747 badArgs: 3748 Tcl_WrongNumArgs(interp, 2, objv, 3749 "?-command? ?-variable? name"); 3750 return TCL_ERROR; 3751 } 3752 3753 /* 3754 * Look for a flag controlling the lookup. 3755 */ 3756 3757 argIndex = 2; 3758 lookup = 0; /* assume command lookup by default */ 3759 arg = Tcl_GetString(objv[2]); 3760 if (*arg == '-') { 3761 if (strncmp(arg, "-command", 8) == 0) { 3762 lookup = 0; 3763 } else if (strncmp(arg, "-variable", 9) == 0) { 3764 lookup = 1; 3765 } else { 3766 goto badArgs; 3767 } 3768 argIndex = 3; 3769 } 3770 if (objc != (argIndex + 1)) { 3771 goto badArgs; 3772 } 3773 3774 switch (lookup) { 3775 case 0: /* -command */ 3776 cmd = Tcl_GetCommandFromObj(interp, objv[argIndex]); 3777 if (cmd == (Tcl_Command) NULL) { 3778 return TCL_OK; /* cmd not found, just return (no error) */ 3779 } 3780 Tcl_GetCommandFullName(interp, cmd, Tcl_GetObjResult(interp)); 3781 break; 3782 3783 case 1: /* -variable */ 3784 arg = Tcl_GetString(objv[argIndex]); 3785 variable = Tcl_FindNamespaceVar(interp, arg, (Tcl_Namespace *) NULL, 3786 /*flags*/ 0); 3787 if (variable != (Tcl_Var) NULL) { 3788 Tcl_GetVariableFullName(interp, variable, Tcl_GetObjResult(interp)); 3789 } 3790 break; 3791 } 3792 return TCL_OK; 3793} 3794 3795/* 3796 *---------------------------------------------------------------------- 3797 * 3798 * FreeNsNameInternalRep -- 3799 * 3800 * Frees the resources associated with a nsName object's internal 3801 * representation. 3802 * 3803 * Results: 3804 * None. 3805 * 3806 * Side effects: 3807 * Decrements the ref count of any Namespace structure pointed 3808 * to by the nsName's internal representation. If there are no more 3809 * references to the namespace, it's structure will be freed. 3810 * 3811 *---------------------------------------------------------------------- 3812 */ 3813 3814static void 3815FreeNsNameInternalRep(objPtr) 3816 register Tcl_Obj *objPtr; /* nsName object with internal 3817 * representation to free */ 3818{ 3819 register ResolvedNsName *resNamePtr = 3820 (ResolvedNsName *) objPtr->internalRep.otherValuePtr; 3821 Namespace *nsPtr; 3822 3823 /* 3824 * Decrement the reference count of the namespace. If there are no 3825 * more references, free it up. 3826 */ 3827 3828 if (resNamePtr != NULL) { 3829 resNamePtr->refCount--; 3830 if (resNamePtr->refCount == 0) { 3831 3832 /* 3833 * Decrement the reference count for the cached namespace. If 3834 * the namespace is dead, and there are no more references to 3835 * it, free it. 3836 */ 3837 3838 nsPtr = resNamePtr->nsPtr; 3839 nsPtr->refCount--; 3840 if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { 3841 NamespaceFree(nsPtr); 3842 } 3843 ckfree((char *) resNamePtr); 3844 } 3845 } 3846} 3847 3848/* 3849 *---------------------------------------------------------------------- 3850 * 3851 * DupNsNameInternalRep -- 3852 * 3853 * Initializes the internal representation of a nsName object to a copy 3854 * of the internal representation of another nsName object. 3855 * 3856 * Results: 3857 * None. 3858 * 3859 * Side effects: 3860 * copyPtr's internal rep is set to refer to the same namespace 3861 * referenced by srcPtr's internal rep. Increments the ref count of 3862 * the ResolvedNsName structure used to hold the namespace reference. 3863 * 3864 *---------------------------------------------------------------------- 3865 */ 3866 3867static void 3868DupNsNameInternalRep(srcPtr, copyPtr) 3869 Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ 3870 register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ 3871{ 3872 register ResolvedNsName *resNamePtr = 3873 (ResolvedNsName *) srcPtr->internalRep.otherValuePtr; 3874 3875 copyPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; 3876 if (resNamePtr != NULL) { 3877 resNamePtr->refCount++; 3878 } 3879 copyPtr->typePtr = &tclNsNameType; 3880} 3881 3882/* 3883 *---------------------------------------------------------------------- 3884 * 3885 * SetNsNameFromAny -- 3886 * 3887 * Attempt to generate a nsName internal representation for a 3888 * Tcl object. 3889 * 3890 * Results: 3891 * Returns TCL_OK if the value could be converted to a proper 3892 * namespace reference. Otherwise, it returns TCL_ERROR, along 3893 * with an error message in the interpreter's result object. 3894 * 3895 * Side effects: 3896 * If successful, the object is made a nsName object. Its internal rep 3897 * is set to point to a ResolvedNsName, which contains a cached pointer 3898 * to the Namespace. Reference counts are kept on both the 3899 * ResolvedNsName and the Namespace, so we can keep track of their 3900 * usage and free them when appropriate. 3901 * 3902 *---------------------------------------------------------------------- 3903 */ 3904 3905static int 3906SetNsNameFromAny(interp, objPtr) 3907 Tcl_Interp *interp; /* Points to the namespace in which to 3908 * resolve name. Also used for error 3909 * reporting if not NULL. */ 3910 register Tcl_Obj *objPtr; /* The object to convert. */ 3911{ 3912 register Tcl_ObjType *oldTypePtr = objPtr->typePtr; 3913 char *name; 3914 CONST char *dummy; 3915 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; 3916 register ResolvedNsName *resNamePtr; 3917 3918 /* 3919 * Get the string representation. Make it up-to-date if necessary. 3920 */ 3921 3922 name = objPtr->bytes; 3923 if (name == NULL) { 3924 name = Tcl_GetString(objPtr); 3925 } 3926 3927 /* 3928 * Look for the namespace "name" in the current namespace. If there is 3929 * an error parsing the (possibly qualified) name, return an error. 3930 * If the namespace isn't found, we convert the object to an nsName 3931 * object with a NULL ResolvedNsName* internal rep. 3932 */ 3933 3934 TclGetNamespaceForQualName(interp, name, (Namespace *) NULL, 3935 FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); 3936 3937 /* 3938 * If we found a namespace, then create a new ResolvedNsName structure 3939 * that holds a reference to it. 3940 */ 3941 3942 if (nsPtr != NULL) { 3943 Namespace *currNsPtr = 3944 (Namespace *) Tcl_GetCurrentNamespace(interp); 3945 3946 nsPtr->refCount++; 3947 resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName)); 3948 resNamePtr->nsPtr = nsPtr; 3949 resNamePtr->nsId = nsPtr->nsId; 3950 resNamePtr->refNsPtr = currNsPtr; 3951 resNamePtr->refCount = 1; 3952 } else { 3953 resNamePtr = NULL; 3954 } 3955 3956 /* 3957 * Free the old internalRep before setting the new one. 3958 * We do this as late as possible to allow the conversion code 3959 * (in particular, Tcl_GetStringFromObj) to use that old internalRep. 3960 */ 3961 3962 if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { 3963 oldTypePtr->freeIntRepProc(objPtr); 3964 } 3965 3966 objPtr->internalRep.otherValuePtr = (VOID *) resNamePtr; 3967 objPtr->typePtr = &tclNsNameType; 3968 return TCL_OK; 3969} 3970 3971/* 3972 *---------------------------------------------------------------------- 3973 * 3974 * UpdateStringOfNsName -- 3975 * 3976 * Updates the string representation for a nsName object. 3977 * Note: This procedure does not free an existing old string rep 3978 * so storage will be lost if this has not already been done. 3979 * 3980 * Results: 3981 * None. 3982 * 3983 * Side effects: 3984 * The object's string is set to a copy of the fully qualified 3985 * namespace name. 3986 * 3987 *---------------------------------------------------------------------- 3988 */ 3989 3990static void 3991UpdateStringOfNsName(objPtr) 3992 register Tcl_Obj *objPtr; /* nsName object with string rep to update. */ 3993{ 3994 ResolvedNsName *resNamePtr = 3995 (ResolvedNsName *) objPtr->internalRep.otherValuePtr; 3996 register Namespace *nsPtr; 3997 char *name = ""; 3998 int length; 3999 4000 if ((resNamePtr != NULL) 4001 && (resNamePtr->nsId == resNamePtr->nsPtr->nsId)) { 4002 nsPtr = resNamePtr->nsPtr; 4003 if (nsPtr->flags & NS_DEAD) { 4004 nsPtr = NULL; 4005 } 4006 if (nsPtr != NULL) { 4007 name = nsPtr->fullName; 4008 } 4009 } 4010 4011 /* 4012 * The following sets the string rep to an empty string on the heap 4013 * if the internal rep is NULL. 4014 */ 4015 4016 length = strlen(name); 4017 if (length == 0) { 4018 objPtr->bytes = tclEmptyStringRep; 4019 } else { 4020 objPtr->bytes = (char *) ckalloc((unsigned) (length + 1)); 4021 memcpy((VOID *) objPtr->bytes, (VOID *) name, (unsigned) length); 4022 objPtr->bytes[length] = '\0'; 4023 } 4024 objPtr->length = length; 4025} 4026