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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25