/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclnamesp.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclnamesp.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25