Fork me on GitHub

source: git/external/tcl/tclNamesp.c@ 952bbbc

Last change on this file since 952bbbc was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

move branches/ModularDelphes to trunk

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