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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25