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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 25 - (show annotations) (download)
Sat Oct 8 06:43:03 2016 UTC (8 years, 1 month ago) by dashley
Original Path: sf_code/esrgpcpj/shared/tcl_base/tclnamesp.c
File MIME type: text/plain
File size: 130166 byte(s)
Initial commit.
1 /* $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