1 /*
2 * tclNamesp.c --
3 *
4 * Contains support for namespaces, which provide a separate context of
5 * commands and global variables. The global :: namespace is the
6 * traditional Tcl "global" scope. Other namespaces are created as
7 * children of the global namespace. These other namespaces contain
8 * special-purpose commands and variables for packages. Also includes the
9 * TIP#112 ensemble machinery.
10 *
11 * Copyright (c) 1993-1997 Lucent Technologies.
12 * Copyright (c) 1997 Sun Microsystems, Inc.
13 * Copyright (c) 1998-1999 by Scriptics Corporation.
14 * Copyright (c) 2002-2005 Donal K. Fellows.
15 * Copyright (c) 2006 Neil Madden.
16 * Contributions from Don Porter, NIST, 2007. (not subject to US copyright)
17 *
18 * Originally implemented by
19 * Michael J. McLennan
20 * Bell Labs Innovations for Lucent Technologies
21 * mmclennan@lucent.com
22 *
23 * See the file "license.terms" for information on usage and redistribution of
24 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
25 */
26
27 #include "tclInt.h"
28
29 /*
30 * Thread-local storage used to avoid having a global lock on data that is not
31 * limited to a single interpreter.
32 */
33
34 typedef struct ThreadSpecificData {
35 long numNsCreated; /* Count of the number of namespaces created
36 * within the thread. This value is used as a
37 * unique id for each namespace. Cannot be
38 * per-interp because the nsId is used to
39 * distinguish objects which can be passed
40 * around between interps in the same thread,
41 * but does not need to be global because
42 * object internal reps are always per-thread
43 * anyway. */
44 } ThreadSpecificData;
45
46 static Tcl_ThreadDataKey dataKey;
47
48 /*
49 * This structure contains a cached pointer to a namespace that is the result
50 * of resolving the namespace's name in some other namespace. It is the
51 * internal representation for a nsName object. It contains the pointer along
52 * with some information that is used to check the cached pointer's validity.
53 */
54
55 typedef struct ResolvedNsName {
56 Namespace *nsPtr; /* A cached pointer to the Namespace that the
57 * name resolved to. */
58 Namespace *refNsPtr; /* Points to the namespace context in which the
59 * name was resolved. NULL if the name is fully
60 * qualified and thus the resolution does not
61 * depend on the context. */
62 int refCount; /* Reference count: 1 for each nsName object
63 * that has a pointer to this ResolvedNsName
64 * structure as its internal rep. This
65 * structure can be freed when refCount
66 * becomes zero. */
67 } ResolvedNsName;
68
69 /*
70 * The client data for an ensemble command. This consists of the table of
71 * commands that are actually exported by the namespace, and an epoch counter
72 * that, combined with the exportLookupEpoch field of the namespace structure,
73 * defines whether the table contains valid data or will need to be recomputed
74 * next time the ensemble command is called.
75 */
76
77 typedef struct EnsembleConfig {
78 Namespace *nsPtr; /* The namspace backing this ensemble up. */
79 Tcl_Command token; /* The token for the command that provides
80 * ensemble support for the namespace, or NULL
81 * if the command has been deleted (or never
82 * existed; the global namespace never has an
83 * ensemble command.) */
84 int epoch; /* The epoch at which this ensemble's table of
85 * exported commands is valid. */
86 char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
87 * consistent points, this will have the same
88 * number of entries as there are entries in
89 * the subcommandTable hash. */
90 Tcl_HashTable subcommandTable;
91 /* Hash table of ensemble subcommand names,
92 * which are its keys so this also provides
93 * the storage management for those subcommand
94 * names. The contents of the entry values are
95 * object version the prefix lists to use when
96 * substituting for the command/subcommand to
97 * build the ensemble implementation command.
98 * Has to be stored here as well as in
99 * subcommandDict because that field is NULL
100 * when we are deriving the ensemble from the
101 * namespace exports list. FUTURE WORK: use
102 * object hash table here. */
103 struct EnsembleConfig *next;/* The next ensemble in the linked list of
104 * ensembles associated with a namespace. If
105 * this field points to this ensemble, the
106 * structure has already been unlinked from
107 * all lists, and cannot be found by scanning
108 * the list from the namespace's ensemble
109 * field. */
110 int flags; /* ORed combo of TCL_ENSEMBLE_PREFIX, ENS_DEAD
111 * and ENSEMBLE_COMPILE. */
112
113 /* OBJECT FIELDS FOR ENSEMBLE CONFIGURATION */
114
115 Tcl_Obj *subcommandDict; /* Dictionary providing mapping from
116 * subcommands to their implementing command
117 * prefixes, or NULL if we are to build the
118 * map automatically from the namespace
119 * exports. */
120 Tcl_Obj *subcmdList; /* List of commands that this ensemble
121 * actually provides, and whose implementation
122 * will be built using the subcommandDict (if
123 * present and defined) and by simple mapping
124 * to the namespace otherwise. If NULL,
125 * indicates that we are using the (dynamic)
126 * list of currently exported commands. */
127 Tcl_Obj *unknownHandler; /* Script prefix used to handle the case when
128 * no match is found (according to the rule
129 * defined by flag bit TCL_ENSEMBLE_PREFIX) or
130 * NULL to use the default error-generating
131 * behaviour. The script execution gets all
132 * the arguments to the ensemble command
133 * (including objv[0]) and will have the
134 * results passed directly back to the caller
135 * (including the error code) unless the code
136 * is TCL_CONTINUE in which case the
137 * subcommand will be reparsed by the ensemble
138 * core, presumably because the ensemble
139 * itself has been updated. */
140 } EnsembleConfig;
141
142 #define ENS_DEAD 0x1 /* Flag value to say that the ensemble is dead
143 * and on its way out. */
144
145 /*
146 * Declarations for functions local to this file:
147 */
148
149 static void DeleteImportedCmd(ClientData clientData);
150 static int DoImport(Tcl_Interp *interp,
151 Namespace *nsPtr, Tcl_HashEntry *hPtr,
152 const char *cmdName, const char *pattern,
153 Namespace *importNsPtr, int allowOverwrite);
154 static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr);
155 static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp,
156 const char *name1, const char *name2, int flags);
157 static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp,
158 const char *name1, const char *name2, int flags);
159 static char * EstablishErrorCodeTraces(ClientData clientData,
160 Tcl_Interp *interp, const char *name1,
161 const char *name2, int flags);
162 static char * EstablishErrorInfoTraces(ClientData clientData,
163 Tcl_Interp *interp, const char *name1,
164 const char *name2, int flags);
165 static void FreeNsNameInternalRep(Tcl_Obj *objPtr);
166 static int GetNamespaceFromObj(Tcl_Interp *interp,
167 Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr);
168 static int InvokeImportedCmd(ClientData clientData,
169 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
170 static int NamespaceChildrenCmd(ClientData dummy,
171 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
172 static int NamespaceCodeCmd(ClientData dummy, Tcl_Interp *interp,
173 int objc, Tcl_Obj *const objv[]);
174 static int NamespaceCurrentCmd(ClientData dummy,
175 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
176 static int NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
177 int objc, Tcl_Obj *const objv[]);
178 static int NamespaceEnsembleCmd(ClientData dummy,
179 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
180 static int NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
181 int objc, Tcl_Obj *const objv[]);
182 static int NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
183 int objc, Tcl_Obj *const objv[]);
184 static int NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
185 int objc, Tcl_Obj *const objv[]);
186 static int NamespaceForgetCmd(ClientData dummy,Tcl_Interp *interp,
187 int objc, Tcl_Obj *const objv[]);
188 static void NamespaceFree(Namespace *nsPtr);
189 static int NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
190 int objc, Tcl_Obj *const objv[]);
191 static int NamespaceInscopeCmd(ClientData dummy,
192 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
193 static int NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
194 int objc, Tcl_Obj *const objv[]);
195 static int NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
196 int objc, Tcl_Obj *const objv[]);
197 static int NamespacePathCmd(ClientData dummy, Tcl_Interp *interp,
198 int objc, Tcl_Obj *const objv[]);
199 static int NamespaceQualifiersCmd(ClientData dummy,
200 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
201 static int NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
202 int objc, Tcl_Obj *const objv[]);
203 static int NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
204 int objc, Tcl_Obj *const objv[]);
205 static int NamespaceUnknownCmd(ClientData dummy,
206 Tcl_Interp *interp, int objc,
207 Tcl_Obj *const objv[]);
208 static int NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
209 int objc, Tcl_Obj *const objv[]);
210 static int SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
211 static int NsEnsembleImplementationCmd(ClientData clientData,
212 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
213 static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
214 static int NsEnsembleStringOrder(const void *strPtr1,
215 const void *strPtr2);
216 static void DeleteEnsembleConfig(ClientData clientData);
217 static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
218 EnsembleConfig *ensemblePtr,
219 const char *subcmdName, Tcl_Obj *prefixObjPtr);
220 static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
221 static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
222 static void StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
223 static void UnlinkNsPath(Namespace *nsPtr);
224
225 /*
226 * This structure defines a Tcl object type that contains a namespace
227 * reference. It is used in commands that take the name of a namespace as an
228 * argument. The namespace reference is resolved, and the result in cached in
229 * the object.
230 */
231
232 static Tcl_ObjType nsNameType = {
233 "nsName", /* the type's name */
234 FreeNsNameInternalRep, /* freeIntRepProc */
235 DupNsNameInternalRep, /* dupIntRepProc */
236 NULL, /* updateStringProc */
237 SetNsNameFromAny /* setFromAnyProc */
238 };
239
240 /*
241 * This structure defines a Tcl object type that contains a reference to an
242 * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
243 * to cache the mapping between the subcommand itself and the real command
244 * that implements it.
245 */
246
247 Tcl_ObjType tclEnsembleCmdType = {
248 "ensembleCommand", /* the type's name */
249 FreeEnsembleCmdRep, /* freeIntRepProc */
250 DupEnsembleCmdRep, /* dupIntRepProc */
251 StringOfEnsembleCmdRep, /* updateStringProc */
252 NULL /* setFromAnyProc */
253 };
254
255 /*
256 *----------------------------------------------------------------------
257 *
258 * TclInitNamespaceSubsystem --
259 *
260 * This function is called to initialize all the structures that are used
261 * by namespaces on a per-process basis.
262 *
263 * Results:
264 * None.
265 *
266 * Side effects:
267 * None.
268 *
269 *----------------------------------------------------------------------
270 */
271
272 void
TclInitNamespaceSubsystem(void)273 TclInitNamespaceSubsystem(void)
274 {
275 /*
276 * Does nothing for now.
277 */
278 }
279
280 /*
281 *----------------------------------------------------------------------
282 *
283 * Tcl_GetCurrentNamespace --
284 *
285 * Returns a pointer to an interpreter's currently active namespace.
286 *
287 * Results:
288 * Returns a pointer to the interpreter's current namespace.
289 *
290 * Side effects:
291 * None.
292 *
293 *----------------------------------------------------------------------
294 */
295
296 Tcl_Namespace *
Tcl_GetCurrentNamespace(register Tcl_Interp * interp)297 Tcl_GetCurrentNamespace(
298 register Tcl_Interp *interp)/* Interpreter whose current namespace is
299 * being queried. */
300 {
301 return TclGetCurrentNamespace(interp);
302 }
303
304 /*
305 *----------------------------------------------------------------------
306 *
307 * Tcl_GetGlobalNamespace --
308 *
309 * Returns a pointer to an interpreter's global :: namespace.
310 *
311 * Results:
312 * Returns a pointer to the specified interpreter's global namespace.
313 *
314 * Side effects:
315 * None.
316 *
317 *----------------------------------------------------------------------
318 */
319
320 Tcl_Namespace *
Tcl_GetGlobalNamespace(register Tcl_Interp * interp)321 Tcl_GetGlobalNamespace(
322 register Tcl_Interp *interp)/* Interpreter whose global namespace should
323 * be returned. */
324 {
325 return TclGetGlobalNamespace(interp);
326 }
327
328 /*
329 *----------------------------------------------------------------------
330 *
331 * Tcl_PushCallFrame --
332 *
333 * Pushes a new call frame onto the interpreter's Tcl call stack. Called
334 * when executing a Tcl procedure or a "namespace eval" or "namespace
335 * inscope" command.
336 *
337 * Results:
338 * Returns TCL_OK if successful, or TCL_ERROR (along with an error
339 * message in the interpreter's result object) if something goes wrong.
340 *
341 * Side effects:
342 * Modifies the interpreter's Tcl call stack.
343 *
344 *----------------------------------------------------------------------
345 */
346
347 int
Tcl_PushCallFrame(Tcl_Interp * interp,Tcl_CallFrame * callFramePtr,Tcl_Namespace * namespacePtr,int isProcCallFrame)348 Tcl_PushCallFrame(
349 Tcl_Interp *interp, /* Interpreter in which the new call frame is
350 * to be pushed. */
351 Tcl_CallFrame *callFramePtr,/* Points to a call frame structure to push.
352 * Storage for this has already been allocated
353 * by the caller; typically this is the
354 * address of a CallFrame structure allocated
355 * on the caller's C stack. The call frame
356 * will be initialized by this function. The
357 * caller can pop the frame later with
358 * Tcl_PopCallFrame, and it is responsible for
359 * freeing the frame's storage. */
360 Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
361 * will execute. If NULL, the interpreter's
362 * current namespace will be used. */
363 int isProcCallFrame) /* If nonzero, the frame represents a called
364 * Tcl procedure and may have local vars. Vars
365 * will ordinarily be looked up in the frame.
366 * If new variables are created, they will be
367 * created in the frame. If 0, the frame is
368 * for a "namespace eval" or "namespace
369 * inscope" command and var references are
370 * treated as references to namespace
371 * variables. */
372 {
373 Interp *iPtr = (Interp *) interp;
374 register CallFrame *framePtr = (CallFrame *) callFramePtr;
375 register Namespace *nsPtr;
376
377 if (namespacePtr == NULL) {
378 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
379 } else {
380 nsPtr = (Namespace *) namespacePtr;
381
382 /*
383 * TODO: Examine whether it would be better to guard based on NS_DYING
384 * or NS_KILLED. It appears that these are not tested because they can
385 * be set in a global interp that has been [namespace delete]d, but
386 * which never really completely goes away because of lingering global
387 * things like ::errorInfo and [::unknown] and hidden commands.
388 * Review of those designs might permit stricter checking here.
389 */
390
391 if (nsPtr->flags & NS_DEAD) {
392 Tcl_Panic("Trying to push call frame for dead namespace");
393 /*NOTREACHED*/
394 }
395 }
396
397 nsPtr->activationCount++;
398 framePtr->nsPtr = nsPtr;
399 framePtr->isProcCallFrame = isProcCallFrame;
400 framePtr->objc = 0;
401 framePtr->objv = NULL;
402 framePtr->callerPtr = iPtr->framePtr;
403 framePtr->callerVarPtr = iPtr->varFramePtr;
404 if (iPtr->varFramePtr != NULL) {
405 framePtr->level = (iPtr->varFramePtr->level + 1);
406 } else {
407 framePtr->level = 0;
408 }
409 framePtr->procPtr = NULL; /* no called procedure */
410 framePtr->varTablePtr = NULL; /* and no local variables */
411 framePtr->numCompiledLocals = 0;
412 framePtr->compiledLocals = NULL;
413 framePtr->clientData = NULL;
414 framePtr->localCachePtr = NULL;
415
416 /*
417 * Push the new call frame onto the interpreter's stack of procedure call
418 * frames making it the current frame.
419 */
420
421 iPtr->framePtr = framePtr;
422 iPtr->varFramePtr = framePtr;
423 return TCL_OK;
424 }
425
426 /*
427 *----------------------------------------------------------------------
428 *
429 * Tcl_PopCallFrame --
430 *
431 * Removes a call frame from the Tcl call stack for the interpreter.
432 * Called to remove a frame previously pushed by Tcl_PushCallFrame.
433 *
434 * Results:
435 * None.
436 *
437 * Side effects:
438 * Modifies the call stack of the interpreter. Resets various fields of
439 * the popped call frame. If a namespace has been deleted and has no more
440 * activations on the call stack, the namespace is destroyed.
441 *
442 *----------------------------------------------------------------------
443 */
444
445 void
Tcl_PopCallFrame(Tcl_Interp * interp)446 Tcl_PopCallFrame(
447 Tcl_Interp *interp) /* Interpreter with call frame to pop. */
448 {
449 register Interp *iPtr = (Interp *) interp;
450 register CallFrame *framePtr = iPtr->framePtr;
451 Namespace *nsPtr;
452
453 /*
454 * It's important to remove the call frame from the interpreter's stack of
455 * call frames before deleting local variables, so that traces invoked by
456 * the variable deletion don't see the partially-deleted frame.
457 */
458
459 if (framePtr->callerPtr) {
460 iPtr->framePtr = framePtr->callerPtr;
461 iPtr->varFramePtr = framePtr->callerVarPtr;
462 } else {
463 /* Tcl_PopCallFrame: trying to pop rootCallFrame! */
464 }
465
466 if (framePtr->varTablePtr != NULL) {
467 TclDeleteVars(iPtr, framePtr->varTablePtr);
468 ckfree((char *) framePtr->varTablePtr);
469 framePtr->varTablePtr = NULL;
470 }
471 if (framePtr->numCompiledLocals > 0) {
472 TclDeleteCompiledLocalVars(iPtr, framePtr);
473 if (--framePtr->localCachePtr->refCount == 0) {
474 TclFreeLocalCache(interp, framePtr->localCachePtr);
475 }
476 framePtr->localCachePtr = NULL;
477 }
478
479 /*
480 * Decrement the namespace's count of active call frames. If the namespace
481 * is "dying" and there are no more active call frames, call
482 * Tcl_DeleteNamespace to destroy it.
483 */
484
485 nsPtr = framePtr->nsPtr;
486 nsPtr->activationCount--;
487 if ((nsPtr->flags & NS_DYING)
488 && (nsPtr->activationCount - (nsPtr == iPtr->globalNsPtr) == 0)) {
489 Tcl_DeleteNamespace((Tcl_Namespace *) nsPtr);
490 }
491 framePtr->nsPtr = NULL;
492 }
493
494 /*
495 *----------------------------------------------------------------------
496 *
497 * TclPushStackFrame --
498 *
499 * Allocates a new call frame in the interpreter's execution stack, then
500 * pushes it onto the interpreter's Tcl call stack. Called when executing
501 * a Tcl procedure or a "namespace eval" or "namespace inscope" command.
502 *
503 * Results:
504 * Returns TCL_OK if successful, or TCL_ERROR (along with an error
505 * message in the interpreter's result object) if something goes wrong.
506 *
507 * Side effects:
508 * Modifies the interpreter's Tcl call stack.
509 *
510 *----------------------------------------------------------------------
511 */
512
513 int
TclPushStackFrame(Tcl_Interp * interp,Tcl_CallFrame ** framePtrPtr,Tcl_Namespace * namespacePtr,int isProcCallFrame)514 TclPushStackFrame(
515 Tcl_Interp *interp, /* Interpreter in which the new call frame is
516 * to be pushed. */
517 Tcl_CallFrame **framePtrPtr,/* Place to store a pointer to the stack
518 * allocated call frame. */
519 Tcl_Namespace *namespacePtr,/* Points to the namespace in which the frame
520 * will execute. If NULL, the interpreter's
521 * current namespace will be used. */
522 int isProcCallFrame) /* If nonzero, the frame represents a called
523 * Tcl procedure and may have local vars. Vars
524 * will ordinarily be looked up in the frame.
525 * If new variables are created, they will be
526 * created in the frame. If 0, the frame is
527 * for a "namespace eval" or "namespace
528 * inscope" command and var references are
529 * treated as references to namespace
530 * variables. */
531 {
532 *framePtrPtr = (Tcl_CallFrame *) TclStackAlloc(interp, sizeof(CallFrame));
533 return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
534 isProcCallFrame);
535 }
536
537 void
TclPopStackFrame(Tcl_Interp * interp)538 TclPopStackFrame(
539 Tcl_Interp *interp) /* Interpreter with call frame to pop. */
540 {
541 CallFrame *freePtr = ((Interp *)interp)->framePtr;
542
543 Tcl_PopCallFrame(interp);
544 TclStackFree(interp, freePtr);
545 }
546
547 /*
548 *----------------------------------------------------------------------
549 *
550 * EstablishErrorCodeTraces --
551 *
552 * Creates traces on the ::errorCode variable to keep its value
553 * consistent with the expectations of legacy code.
554 *
555 * Results:
556 * None.
557 *
558 * Side effects:
559 * Read and unset traces are established on ::errorCode.
560 *
561 *----------------------------------------------------------------------
562 */
563
564 static char *
EstablishErrorCodeTraces(ClientData clientData,Tcl_Interp * interp,const char * name1,const char * name2,int flags)565 EstablishErrorCodeTraces(
566 ClientData clientData,
567 Tcl_Interp *interp,
568 const char *name1,
569 const char *name2,
570 int flags)
571 {
572 Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
573 ErrorCodeRead, NULL);
574 Tcl_TraceVar(interp, "errorCode", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
575 EstablishErrorCodeTraces, NULL);
576 return NULL;
577 }
578
579 /*
580 *----------------------------------------------------------------------
581 *
582 * ErrorCodeRead --
583 *
584 * Called when the ::errorCode variable is read. Copies the current value
585 * of the interp's errorCode field into ::errorCode.
586 *
587 * Results:
588 * None.
589 *
590 * Side effects:
591 * None.
592 *
593 *----------------------------------------------------------------------
594 */
595
596 static char *
ErrorCodeRead(ClientData clientData,Tcl_Interp * interp,const char * name1,const char * name2,int flags)597 ErrorCodeRead(
598 ClientData clientData,
599 Tcl_Interp *interp,
600 const char *name1,
601 const char *name2,
602 int flags)
603 {
604 Interp *iPtr = (Interp *)interp;
605
606 if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
607 return NULL;
608 }
609 if (iPtr->errorCode) {
610 Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
611 iPtr->errorCode, TCL_GLOBAL_ONLY);
612 return NULL;
613 }
614 if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) {
615 Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL,
616 Tcl_NewObj(), TCL_GLOBAL_ONLY);
617 }
618 return NULL;
619 }
620
621 /*
622 *----------------------------------------------------------------------
623 *
624 * EstablishErrorInfoTraces --
625 *
626 * Creates traces on the ::errorInfo variable to keep its value
627 * consistent with the expectations of legacy code.
628 *
629 * Results:
630 * None.
631 *
632 * Side effects:
633 * Read and unset traces are established on ::errorInfo.
634 *
635 *----------------------------------------------------------------------
636 */
637
638 static char *
EstablishErrorInfoTraces(ClientData clientData,Tcl_Interp * interp,const char * name1,const char * name2,int flags)639 EstablishErrorInfoTraces(
640 ClientData clientData,
641 Tcl_Interp *interp,
642 const char *name1,
643 const char *name2,
644 int flags)
645 {
646 Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_READS,
647 ErrorInfoRead, NULL);
648 Tcl_TraceVar(interp, "errorInfo", TCL_GLOBAL_ONLY | TCL_TRACE_UNSETS,
649 EstablishErrorInfoTraces, NULL);
650 return NULL;
651 }
652
653 /*
654 *----------------------------------------------------------------------
655 *
656 * ErrorInfoRead --
657 *
658 * Called when the ::errorInfo variable is read. Copies the current value
659 * of the interp's errorInfo field into ::errorInfo.
660 *
661 * Results:
662 * None.
663 *
664 * Side effects:
665 * None.
666 *
667 *----------------------------------------------------------------------
668 */
669
670 static char *
ErrorInfoRead(ClientData clientData,Tcl_Interp * interp,const char * name1,const char * name2,int flags)671 ErrorInfoRead(
672 ClientData clientData,
673 Tcl_Interp *interp,
674 const char *name1,
675 const char *name2,
676 int flags)
677 {
678 Interp *iPtr = (Interp *) interp;
679
680 if (Tcl_InterpDeleted(interp) || !(iPtr->flags & ERR_LEGACY_COPY)) {
681 return NULL;
682 }
683 if (iPtr->errorInfo) {
684 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
685 iPtr->errorInfo, TCL_GLOBAL_ONLY);
686 return NULL;
687 }
688 if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) {
689 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL,
690 Tcl_NewObj(), TCL_GLOBAL_ONLY);
691 }
692 return NULL;
693 }
694
695 /*
696 *----------------------------------------------------------------------
697 *
698 * Tcl_CreateNamespace --
699 *
700 * Creates a new namespace with the given name. If there is no active
701 * namespace (i.e., the interpreter is being initialized), the global ::
702 * namespace is created and returned.
703 *
704 * Results:
705 * Returns a pointer to the new namespace if successful. If the namespace
706 * already exists or if another error occurs, this routine returns NULL,
707 * along with an error message in the interpreter's result object.
708 *
709 * Side effects:
710 * If the name contains "::" qualifiers and a parent namespace does not
711 * already exist, it is automatically created.
712 *
713 *----------------------------------------------------------------------
714 */
715
716 Tcl_Namespace *
Tcl_CreateNamespace(Tcl_Interp * interp,const char * name,ClientData clientData,Tcl_NamespaceDeleteProc * deleteProc)717 Tcl_CreateNamespace(
718 Tcl_Interp *interp, /* Interpreter in which a new namespace is
719 * being created. Also used for error
720 * reporting. */
721 const char *name, /* Name for the new namespace. May be a
722 * qualified name with names of ancestor
723 * namespaces separated by "::"s. */
724 ClientData clientData, /* One-word value to store with namespace. */
725 Tcl_NamespaceDeleteProc *deleteProc)
726 /* Function called to delete client data when
727 * the namespace is deleted. NULL if no
728 * function should be called. */
729 {
730 Interp *iPtr = (Interp *) interp;
731 register Namespace *nsPtr, *ancestorPtr;
732 Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
733 Namespace *globalNsPtr = iPtr->globalNsPtr;
734 const char *simpleName;
735 Tcl_HashEntry *entryPtr;
736 Tcl_DString buffer1, buffer2;
737 Tcl_DString *namePtr, *buffPtr;
738 int newEntry, nameLen;
739 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
740 const char *nameStr;
741 Tcl_DString tmpBuffer;
742
743 Tcl_DStringInit(&tmpBuffer);
744
745 /*
746 * If there is no active namespace, the interpreter is being initialized.
747 */
748
749 if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
750 /*
751 * Treat this namespace as the global namespace, and avoid looking for
752 * a parent.
753 */
754
755 parentPtr = NULL;
756 simpleName = "";
757 goto doCreate;
758 }
759
760 /*
761 * Ensure that there are no trailing colons as that causes chaos when a
762 * deleteProc is specified. [Bug d614d63989]
763 */
764
765 if (deleteProc != NULL) {
766 nameStr = name + strlen(name) - 2;
767 if (nameStr >= name && nameStr[1] == ':' && nameStr[0] == ':') {
768 Tcl_DStringAppend(&tmpBuffer, name, -1);
769 while ((nameLen = Tcl_DStringLength(&tmpBuffer)) > 0
770 && Tcl_DStringValue(&tmpBuffer)[nameLen-1] == ':') {
771 Tcl_DStringSetLength(&tmpBuffer, nameLen-1);
772 }
773 name = Tcl_DStringValue(&tmpBuffer);
774 }
775 }
776
777 /*
778 * If we've ended up with an empty string now, we're attempting to create
779 * the global namespace despite the global namespace existing. That's
780 * naughty!
781 */
782
783 if (*name == '\0') {
784 Tcl_ResetResult(interp);
785 Tcl_AppendResult(interp, "can't create namespace \"\": "
786 "only global namespace can have empty name", NULL);
787 Tcl_DStringFree(&tmpBuffer);
788 return NULL;
789 }
790
791 /*
792 * Find the parent for the new namespace.
793 */
794
795 TclGetNamespaceForQualName(interp, name, NULL, TCL_CREATE_NS_IF_UNKNOWN,
796 &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
797
798 /*
799 * If the unqualified name at the end is empty, there were trailing "::"s
800 * after the namespace's name which we ignore. The new namespace was
801 * already (recursively) created and is pointed to by parentPtr.
802 */
803
804 if (*simpleName == '\0') {
805 Tcl_DStringFree(&tmpBuffer);
806 return (Tcl_Namespace *) parentPtr;
807 }
808
809 /*
810 * Check for a bad namespace name and make sure that the name does not
811 * already exist in the parent namespace.
812 */
813
814 if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
815 Tcl_AppendResult(interp, "can't create namespace \"", name,
816 "\": already exists", NULL);
817 Tcl_DStringFree(&tmpBuffer);
818 return NULL;
819 }
820
821 /*
822 * Create the new namespace and root it in its parent. Increment the count
823 * of namespaces created.
824 */
825
826 doCreate:
827 nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
828 nsPtr->name = ckalloc((unsigned) (strlen(simpleName)+1));
829 strcpy(nsPtr->name, simpleName);
830 nsPtr->fullName = NULL; /* Set below. */
831 nsPtr->clientData = clientData;
832 nsPtr->deleteProc = deleteProc;
833 nsPtr->parentPtr = parentPtr;
834 Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
835 nsPtr->nsId = ++(tsdPtr->numNsCreated);
836 nsPtr->interp = interp;
837 nsPtr->flags = 0;
838 nsPtr->activationCount = 0;
839 nsPtr->refCount = 0;
840 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
841 TclInitVarHashTable(&nsPtr->varTable, nsPtr);
842 nsPtr->exportArrayPtr = NULL;
843 nsPtr->numExportPatterns = 0;
844 nsPtr->maxExportPatterns = 0;
845 nsPtr->cmdRefEpoch = 0;
846 nsPtr->resolverEpoch = 0;
847 nsPtr->cmdResProc = NULL;
848 nsPtr->varResProc = NULL;
849 nsPtr->compiledVarResProc = NULL;
850 nsPtr->exportLookupEpoch = 0;
851 nsPtr->ensembles = NULL;
852 nsPtr->unknownHandlerPtr = NULL;
853 nsPtr->commandPathLength = 0;
854 nsPtr->commandPathArray = NULL;
855 nsPtr->commandPathSourceList = NULL;
856
857 if (parentPtr != NULL) {
858 entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
859 &newEntry);
860 Tcl_SetHashValue(entryPtr, nsPtr);
861 } else {
862 /*
863 * In the global namespace create traces to maintain the ::errorInfo
864 * and ::errorCode variables.
865 */
866
867 iPtr->globalNsPtr = nsPtr;
868 EstablishErrorInfoTraces(NULL, interp, NULL, NULL, 0);
869 EstablishErrorCodeTraces(NULL, interp, NULL, NULL, 0);
870 }
871
872 /*
873 * Build the fully qualified name for this namespace.
874 */
875
876 Tcl_DStringInit(&buffer1);
877 Tcl_DStringInit(&buffer2);
878 namePtr = &buffer1;
879 buffPtr = &buffer2;
880 for (ancestorPtr = nsPtr; ancestorPtr != NULL;
881 ancestorPtr = ancestorPtr->parentPtr) {
882 if (ancestorPtr != globalNsPtr) {
883 register Tcl_DString *tempPtr = namePtr;
884
885 Tcl_DStringAppend(buffPtr, "::", 2);
886 Tcl_DStringAppend(buffPtr, ancestorPtr->name, -1);
887 Tcl_DStringAppend(buffPtr, Tcl_DStringValue(namePtr),
888 Tcl_DStringLength(namePtr));
889
890 /*
891 * Clear the unwanted buffer or we end up appending to previous
892 * results, making the namespace fullNames of nested namespaces
893 * very wrong (and strange).
894 */
895
896 Tcl_DStringSetLength(namePtr, 0);
897
898 /*
899 * Now swap the buffer pointers so that we build in the other
900 * buffer. This is faster than repeated copying back and forth
901 * between buffers.
902 */
903
904 namePtr = buffPtr;
905 buffPtr = tempPtr;
906 }
907 }
908
909 name = Tcl_DStringValue(namePtr);
910 nameLen = Tcl_DStringLength(namePtr);
911 nsPtr->fullName = ckalloc((unsigned) (nameLen+1));
912 memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);
913
914 Tcl_DStringFree(&buffer1);
915 Tcl_DStringFree(&buffer2);
916 Tcl_DStringFree(&tmpBuffer);
917
918 /*
919 * Return a pointer to the new namespace.
920 */
921
922 return (Tcl_Namespace *) nsPtr;
923 }
924
925 /*
926 *----------------------------------------------------------------------
927 *
928 * Tcl_DeleteNamespace --
929 *
930 * Deletes a namespace and all of the commands, variables, and other
931 * namespaces within it.
932 *
933 * Results:
934 * None.
935 *
936 * Side effects:
937 * When a namespace is deleted, it is automatically removed as a child of
938 * its parent namespace. Also, all its commands, variables and child
939 * namespaces are deleted.
940 *
941 *----------------------------------------------------------------------
942 */
943
944 void
Tcl_DeleteNamespace(Tcl_Namespace * namespacePtr)945 Tcl_DeleteNamespace(
946 Tcl_Namespace *namespacePtr)/* Points to the namespace to delete. */
947 {
948 register Namespace *nsPtr = (Namespace *) namespacePtr;
949 Interp *iPtr = (Interp *) nsPtr->interp;
950 Namespace *globalNsPtr = (Namespace *)
951 TclGetGlobalNamespace((Tcl_Interp *) iPtr);
952 Tcl_HashEntry *entryPtr;
953
954 /*
955 * If the namespace has associated ensemble commands, delete them first.
956 * This leaves the actual contents of the namespace alone (unless they are
957 * linked ensemble commands, of course). Note that this code is actually
958 * reentrant so command delete traces won't purturb things badly.
959 */
960
961 while (nsPtr->ensembles != NULL) {
962 EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles;
963
964 /*
965 * Splice out and link to indicate that we've already been killed.
966 */
967
968 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
969 ensemblePtr->next = ensemblePtr;
970 Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token);
971 }
972
973 /*
974 * If the namespace has a registered unknown handler (TIP 181), then free
975 * it here.
976 */
977
978 if (nsPtr->unknownHandlerPtr != NULL) {
979 Tcl_DecrRefCount(nsPtr->unknownHandlerPtr);
980 nsPtr->unknownHandlerPtr = NULL;
981 }
982
983 /*
984 * If the namespace is on the call frame stack, it is marked as "dying"
985 * (NS_DYING is OR'd into its flags): the namespace can't be looked up by
986 * name but its commands and variables are still usable by those active
987 * call frames. When all active call frames referring to the namespace
988 * have been popped from the Tcl stack, Tcl_PopCallFrame will call this
989 * function again to delete everything in the namespace. If no nsName
990 * objects refer to the namespace (i.e., if its refCount is zero), its
991 * commands and variables are deleted and the storage for its namespace
992 * structure is freed. Otherwise, if its refCount is nonzero, the
993 * namespace's commands and variables are deleted but the structure isn't
994 * freed. Instead, NS_DEAD is OR'd into the structure's flags to allow the
995 * namespace resolution code to recognize that the namespace is "deleted".
996 * The structure's storage is freed by FreeNsNameInternalRep when its
997 * refCount reaches 0.
998 */
999
1000 if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
1001 nsPtr->flags |= NS_DYING;
1002 if (nsPtr->parentPtr != NULL) {
1003 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
1004 nsPtr->name);
1005 if (entryPtr != NULL) {
1006 Tcl_DeleteHashEntry(entryPtr);
1007 }
1008 }
1009 nsPtr->parentPtr = NULL;
1010 } else if (!(nsPtr->flags & NS_KILLED)) {
1011 /*
1012 * Delete the namespace and everything in it. If this is the global
1013 * namespace, then clear it but don't free its storage unless the
1014 * interpreter is being torn down. Set the NS_KILLED flag to avoid
1015 * recursive calls here - if the namespace is really in the process of
1016 * being deleted, ignore any second call.
1017 */
1018
1019 nsPtr->flags |= (NS_DYING|NS_KILLED);
1020
1021 TclTeardownNamespace(nsPtr);
1022
1023 if ((nsPtr != globalNsPtr) || (iPtr->flags & DELETED)) {
1024 /*
1025 * If this is the global namespace, then it may have residual
1026 * "errorInfo" and "errorCode" variables for errors that occurred
1027 * while it was being torn down. Try to clear the variable list
1028 * one last time.
1029 */
1030
1031 TclDeleteNamespaceVars(nsPtr);
1032
1033 Tcl_DeleteHashTable(&nsPtr->childTable);
1034 Tcl_DeleteHashTable(&nsPtr->cmdTable);
1035
1036 /*
1037 * If the reference count is 0, then discard the namespace.
1038 * Otherwise, mark it as "dead" so that it can't be used.
1039 */
1040
1041 if (nsPtr->refCount == 0) {
1042 NamespaceFree(nsPtr);
1043 } else {
1044 nsPtr->flags |= NS_DEAD;
1045 }
1046 } else {
1047 /*
1048 * Restore the ::errorInfo and ::errorCode traces.
1049 */
1050
1051 EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0);
1052 EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0);
1053
1054 /*
1055 * We didn't really kill it, so remove the KILLED marks, so it can
1056 * get killed later, avoiding mem leaks.
1057 */
1058
1059 nsPtr->flags &= ~(NS_DYING|NS_KILLED);
1060 }
1061 }
1062 }
1063
1064 /*
1065 *----------------------------------------------------------------------
1066 *
1067 * TclTeardownNamespace --
1068 *
1069 * Used internally to dismantle and unlink a namespace when it is
1070 * deleted. Divorces the namespace from its parent, and deletes all
1071 * commands, variables, and child namespaces.
1072 *
1073 * This is kept separate from Tcl_DeleteNamespace so that the global
1074 * namespace can be handled specially.
1075 *
1076 * Results:
1077 * None.
1078 *
1079 * Side effects:
1080 * Removes this namespace from its parent's child namespace hashtable.
1081 * Deletes all commands, variables and namespaces in this namespace.
1082 *
1083 *----------------------------------------------------------------------
1084 */
1085
1086 void
TclTeardownNamespace(register Namespace * nsPtr)1087 TclTeardownNamespace(
1088 register Namespace *nsPtr) /* Points to the namespace to be dismantled
1089 * and unlinked from its parent. */
1090 {
1091 Interp *iPtr = (Interp *) nsPtr->interp;
1092 register Tcl_HashEntry *entryPtr;
1093 Tcl_HashSearch search;
1094 Tcl_Namespace *childNsPtr;
1095 Tcl_Command cmd;
1096 int i;
1097
1098 /*
1099 * Start by destroying the namespace's variable table, since variables
1100 * might trigger traces. Variable table should be cleared but not freed!
1101 * TclDeleteNamespaceVars frees it, so we reinitialize it afterwards.
1102 */
1103
1104 TclDeleteNamespaceVars(nsPtr);
1105 TclInitVarHashTable(&nsPtr->varTable, nsPtr);
1106
1107 /*
1108 * Delete all commands in this namespace. Be careful when traversing the
1109 * hash table: when each command is deleted, it removes itself from the
1110 * command table.
1111 *
1112 * Don't optimize to Tcl_NextHashEntry() because of traces.
1113 */
1114
1115 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1116 entryPtr != NULL;
1117 entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
1118 cmd = Tcl_GetHashValue(entryPtr);
1119 Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, cmd);
1120 }
1121 Tcl_DeleteHashTable(&nsPtr->cmdTable);
1122 Tcl_InitHashTable(&nsPtr->cmdTable, TCL_STRING_KEYS);
1123
1124 /*
1125 * Remove the namespace from its parent's child hashtable.
1126 */
1127
1128 if (nsPtr->parentPtr != NULL) {
1129 entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
1130 nsPtr->name);
1131 if (entryPtr != NULL) {
1132 Tcl_DeleteHashEntry(entryPtr);
1133 }
1134 }
1135 nsPtr->parentPtr = NULL;
1136
1137 /*
1138 * Delete the namespace path if one is installed.
1139 */
1140
1141 if (nsPtr->commandPathLength != 0) {
1142 UnlinkNsPath(nsPtr);
1143 nsPtr->commandPathLength = 0;
1144 }
1145 if (nsPtr->commandPathSourceList != NULL) {
1146 NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
1147 do {
1148 if (nsPathPtr->nsPtr != NULL && nsPathPtr->creatorNsPtr != NULL) {
1149 nsPathPtr->creatorNsPtr->cmdRefEpoch++;
1150 }
1151 nsPathPtr->nsPtr = NULL;
1152 nsPathPtr = nsPathPtr->nextPtr;
1153 } while (nsPathPtr != NULL);
1154 nsPtr->commandPathSourceList = NULL;
1155 }
1156
1157 /*
1158 * Delete all the child namespaces.
1159 *
1160 * BE CAREFUL: When each child is deleted, it will divorce itself from its
1161 * parent. You can't traverse a hash table properly if its elements are
1162 * being deleted. We use only the Tcl_FirstHashEntry function to be safe.
1163 *
1164 * Don't optimize to Tcl_NextHashEntry() because of traces.
1165 */
1166
1167 for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
1168 entryPtr != NULL;
1169 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
1170 childNsPtr = Tcl_GetHashValue(entryPtr);
1171 Tcl_DeleteNamespace(childNsPtr);
1172 }
1173
1174 /*
1175 * Free the namespace's export pattern array.
1176 */
1177
1178 if (nsPtr->exportArrayPtr != NULL) {
1179 for (i = 0; i < nsPtr->numExportPatterns; i++) {
1180 ckfree(nsPtr->exportArrayPtr[i]);
1181 }
1182 ckfree((char *) nsPtr->exportArrayPtr);
1183 nsPtr->exportArrayPtr = NULL;
1184 nsPtr->numExportPatterns = 0;
1185 nsPtr->maxExportPatterns = 0;
1186 }
1187
1188 /*
1189 * Free any client data associated with the namespace.
1190 */
1191
1192 if (nsPtr->deleteProc != NULL) {
1193 (*nsPtr->deleteProc)(nsPtr->clientData);
1194 }
1195 nsPtr->deleteProc = NULL;
1196 nsPtr->clientData = NULL;
1197
1198 /*
1199 * Reset the namespace's id field to ensure that this namespace won't be
1200 * interpreted as valid by, e.g., the cache validation code for cached
1201 * command references in Tcl_GetCommandFromObj.
1202 */
1203
1204 nsPtr->nsId = 0;
1205 }
1206
1207 /*
1208 *----------------------------------------------------------------------
1209 *
1210 * NamespaceFree --
1211 *
1212 * Called after a namespace has been deleted, when its reference count
1213 * reaches 0. Frees the data structure representing the namespace.
1214 *
1215 * Results:
1216 * None.
1217 *
1218 * Side effects:
1219 * None.
1220 *
1221 *----------------------------------------------------------------------
1222 */
1223
1224 static void
NamespaceFree(register Namespace * nsPtr)1225 NamespaceFree(
1226 register Namespace *nsPtr) /* Points to the namespace to free. */
1227 {
1228 /*
1229 * Most of the namespace's contents are freed when the namespace is
1230 * deleted by Tcl_DeleteNamespace. All that remains is to free its names
1231 * (for error messages), and the structure itself.
1232 */
1233
1234 ckfree(nsPtr->name);
1235 ckfree(nsPtr->fullName);
1236
1237 ckfree((char *) nsPtr);
1238 }
1239
1240 /*
1241 *----------------------------------------------------------------------
1242 *
1243 * Tcl_Export --
1244 *
1245 * Makes all the commands matching a pattern available to later be
1246 * imported from the namespace specified by namespacePtr (or the current
1247 * namespace if namespacePtr is NULL). The specified pattern is appended
1248 * onto the namespace's export pattern list, which is optionally cleared
1249 * beforehand.
1250 *
1251 * Results:
1252 * Returns TCL_OK if successful, or TCL_ERROR (along with an error
1253 * message in the interpreter's result) if something goes wrong.
1254 *
1255 * Side effects:
1256 * Appends the export pattern onto the namespace's export list.
1257 * Optionally reset the namespace's export pattern list.
1258 *
1259 *----------------------------------------------------------------------
1260 */
1261
1262 int
Tcl_Export(Tcl_Interp * interp,Tcl_Namespace * namespacePtr,const char * pattern,int resetListFirst)1263 Tcl_Export(
1264 Tcl_Interp *interp, /* Current interpreter. */
1265 Tcl_Namespace *namespacePtr,/* Points to the namespace from which commands
1266 * are to be exported. NULL for the current
1267 * namespace. */
1268 const char *pattern, /* String pattern indicating which commands to
1269 * export. This pattern may not include any
1270 * namespace qualifiers; only commands in the
1271 * specified namespace may be exported. */
1272 int resetListFirst) /* If nonzero, resets the namespace's export
1273 * list before appending. */
1274 {
1275 #define INIT_EXPORT_PATTERNS 5
1276 Namespace *nsPtr, *exportNsPtr, *dummyPtr;
1277 Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1278 const char *simplePattern;
1279 char *patternCpy;
1280 int neededElems, len, i;
1281
1282 /*
1283 * If the specified namespace is NULL, use the current namespace.
1284 */
1285
1286 if (namespacePtr == NULL) {
1287 nsPtr = (Namespace *) currNsPtr;
1288 } else {
1289 nsPtr = (Namespace *) namespacePtr;
1290 }
1291
1292 /*
1293 * If resetListFirst is true (nonzero), clear the namespace's export
1294 * pattern list.
1295 */
1296
1297 if (resetListFirst) {
1298 if (nsPtr->exportArrayPtr != NULL) {
1299 for (i = 0; i < nsPtr->numExportPatterns; i++) {
1300 ckfree(nsPtr->exportArrayPtr[i]);
1301 }
1302 ckfree((char *) nsPtr->exportArrayPtr);
1303 nsPtr->exportArrayPtr = NULL;
1304 TclInvalidateNsCmdLookup(nsPtr);
1305 nsPtr->numExportPatterns = 0;
1306 nsPtr->maxExportPatterns = 0;
1307 }
1308 }
1309
1310 /*
1311 * Check that the pattern doesn't have namespace qualifiers.
1312 */
1313
1314 TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1315 &exportNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1316
1317 if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
1318 Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
1319 "\": pattern can't specify a namespace", NULL);
1320 return TCL_ERROR;
1321 }
1322
1323 /*
1324 * Make sure that we don't already have the pattern in the array
1325 */
1326
1327 if (nsPtr->exportArrayPtr != NULL) {
1328 for (i = 0; i < nsPtr->numExportPatterns; i++) {
1329 if (strcmp(pattern, nsPtr->exportArrayPtr[i]) == 0) {
1330 /*
1331 * The pattern already exists in the list.
1332 */
1333
1334 return TCL_OK;
1335 }
1336 }
1337 }
1338
1339 /*
1340 * Make sure there is room in the namespace's pattern array for the new
1341 * pattern.
1342 */
1343
1344 neededElems = nsPtr->numExportPatterns + 1;
1345 if (neededElems > nsPtr->maxExportPatterns) {
1346 nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
1347 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
1348 nsPtr->exportArrayPtr = (char **)
1349 ckrealloc((char *) nsPtr->exportArrayPtr,
1350 sizeof(char *) * nsPtr->maxExportPatterns);
1351 }
1352
1353 /*
1354 * Add the pattern to the namespace's array of export patterns.
1355 */
1356
1357 len = strlen(pattern);
1358 patternCpy = ckalloc((unsigned) (len + 1));
1359 memcpy(patternCpy, pattern, (unsigned) len + 1);
1360
1361 nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
1362 nsPtr->numExportPatterns++;
1363
1364 /*
1365 * The list of commands actually exported from the namespace might have
1366 * changed (probably will have!) However, we do not need to recompute this
1367 * just yet; next time we need the info will be soon enough.
1368 */
1369
1370 TclInvalidateNsCmdLookup(nsPtr);
1371
1372 return TCL_OK;
1373 #undef INIT_EXPORT_PATTERNS
1374 }
1375
1376 /*
1377 *----------------------------------------------------------------------
1378 *
1379 * Tcl_AppendExportList --
1380 *
1381 * Appends onto the argument object the list of export patterns for the
1382 * specified namespace.
1383 *
1384 * Results:
1385 * The return value is normally TCL_OK; in this case the object
1386 * referenced by objPtr has each export pattern appended to it. If an
1387 * error occurs, TCL_ERROR is returned and the interpreter's result holds
1388 * an error message.
1389 *
1390 * Side effects:
1391 * If necessary, the object referenced by objPtr is converted into a list
1392 * object.
1393 *
1394 *----------------------------------------------------------------------
1395 */
1396
1397 int
Tcl_AppendExportList(Tcl_Interp * interp,Tcl_Namespace * namespacePtr,Tcl_Obj * objPtr)1398 Tcl_AppendExportList(
1399 Tcl_Interp *interp, /* Interpreter used for error reporting. */
1400 Tcl_Namespace *namespacePtr,/* Points to the namespace whose export
1401 * pattern list is appended onto objPtr. NULL
1402 * for the current namespace. */
1403 Tcl_Obj *objPtr) /* Points to the Tcl object onto which the
1404 * export pattern list is appended. */
1405 {
1406 Namespace *nsPtr;
1407 int i, result;
1408
1409 /*
1410 * If the specified namespace is NULL, use the current namespace.
1411 */
1412
1413 if (namespacePtr == NULL) {
1414 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1415 } else {
1416 nsPtr = (Namespace *) namespacePtr;
1417 }
1418
1419 /*
1420 * Append the export pattern list onto objPtr.
1421 */
1422
1423 for (i = 0; i < nsPtr->numExportPatterns; i++) {
1424 result = Tcl_ListObjAppendElement(interp, objPtr,
1425 Tcl_NewStringObj(nsPtr->exportArrayPtr[i], -1));
1426 if (result != TCL_OK) {
1427 return result;
1428 }
1429 }
1430 return TCL_OK;
1431 }
1432
1433 /*
1434 *----------------------------------------------------------------------
1435 *
1436 * Tcl_Import --
1437 *
1438 * Imports all of the commands matching a pattern into the namespace
1439 * specified by namespacePtr (or the current namespace if contextNsPtr is
1440 * NULL). This is done by creating a new command (the "imported command")
1441 * that points to the real command in its original namespace.
1442 *
1443 * If matching commands are on the autoload path but haven't been loaded
1444 * yet, this command forces them to be loaded, then creates the links to
1445 * them.
1446 *
1447 * Results:
1448 * Returns TCL_OK if successful, or TCL_ERROR (along with an error
1449 * message in the interpreter's result) if something goes wrong.
1450 *
1451 * Side effects:
1452 * Creates new commands in the importing namespace. These indirect calls
1453 * back to the real command and are deleted if the real commands are
1454 * deleted.
1455 *
1456 *----------------------------------------------------------------------
1457 */
1458
1459 int
Tcl_Import(Tcl_Interp * interp,Tcl_Namespace * namespacePtr,const char * pattern,int allowOverwrite)1460 Tcl_Import(
1461 Tcl_Interp *interp, /* Current interpreter. */
1462 Tcl_Namespace *namespacePtr,/* Points to the namespace into which the
1463 * commands are to be imported. NULL for the
1464 * current namespace. */
1465 const char *pattern, /* String pattern indicating which commands to
1466 * import. This pattern should be qualified by
1467 * the name of the namespace from which to
1468 * import the command(s). */
1469 int allowOverwrite) /* If nonzero, allow existing commands to be
1470 * overwritten by imported commands. If 0,
1471 * return an error if an imported cmd
1472 * conflicts with an existing one. */
1473 {
1474 Namespace *nsPtr, *importNsPtr, *dummyPtr;
1475 const char *simplePattern;
1476 register Tcl_HashEntry *hPtr;
1477 Tcl_HashSearch search;
1478
1479 /*
1480 * If the specified namespace is NULL, use the current namespace.
1481 */
1482
1483 if (namespacePtr == NULL) {
1484 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1485 } else {
1486 nsPtr = (Namespace *) namespacePtr;
1487 }
1488
1489 /*
1490 * First, invoke the "auto_import" command with the pattern being
1491 * imported. This command is part of the Tcl library. It looks for
1492 * imported commands in autoloaded libraries and loads them in. That way,
1493 * they will be found when we try to create links below.
1494 *
1495 * Note that we don't just call Tcl_EvalObjv() directly because we do not
1496 * want absence of the command to be a failure case.
1497 */
1498
1499 if (Tcl_FindCommand(interp,"auto_import",NULL,TCL_GLOBAL_ONLY) != NULL) {
1500 Tcl_Obj *objv[2];
1501 int result;
1502
1503 TclNewLiteralStringObj(objv[0], "auto_import");
1504 objv[1] = Tcl_NewStringObj(pattern, -1);
1505
1506 Tcl_IncrRefCount(objv[0]);
1507 Tcl_IncrRefCount(objv[1]);
1508 result = Tcl_EvalObjv(interp, 2, objv, TCL_GLOBAL_ONLY);
1509 Tcl_DecrRefCount(objv[0]);
1510 Tcl_DecrRefCount(objv[1]);
1511
1512 if (result != TCL_OK) {
1513 return TCL_ERROR;
1514 }
1515 Tcl_ResetResult(interp);
1516 }
1517
1518 /*
1519 * From the pattern, find the namespace from which we are importing and
1520 * get the simple pattern (no namespace qualifiers or ::'s) at the end.
1521 */
1522
1523 if (strlen(pattern) == 0) {
1524 Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
1525 return TCL_ERROR;
1526 }
1527 TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1528 &importNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1529
1530 if (importNsPtr == NULL) {
1531 Tcl_AppendResult(interp, "unknown namespace in import pattern \"",
1532 pattern, "\"", NULL);
1533 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
1534 return TCL_ERROR;
1535 }
1536 if (importNsPtr == nsPtr) {
1537 if (pattern == simplePattern) {
1538 Tcl_AppendResult(interp,
1539 "no namespace specified in import pattern \"", pattern,
1540 "\"", NULL);
1541 } else {
1542 Tcl_AppendResult(interp, "import pattern \"", pattern,
1543 "\" tries to import from namespace \"",
1544 importNsPtr->name, "\" into itself", NULL);
1545 }
1546 return TCL_ERROR;
1547 }
1548
1549 /*
1550 * Scan through the command table in the source namespace and look for
1551 * exported commands that match the string pattern. Create an "imported
1552 * command" in the current namespace for each imported command; these
1553 * commands redirect their invocations to the "real" command.
1554 */
1555
1556 if ((simplePattern != NULL) && TclMatchIsTrivial(simplePattern)) {
1557 hPtr = Tcl_FindHashEntry(&importNsPtr->cmdTable, simplePattern);
1558 if (hPtr == NULL) {
1559 return TCL_OK;
1560 }
1561 return DoImport(interp, nsPtr, hPtr, simplePattern, pattern,
1562 importNsPtr, allowOverwrite);
1563 }
1564 for (hPtr = Tcl_FirstHashEntry(&importNsPtr->cmdTable, &search);
1565 (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
1566 char *cmdName = Tcl_GetHashKey(&importNsPtr->cmdTable, hPtr);
1567 if (Tcl_StringMatch(cmdName, simplePattern) &&
1568 DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr,
1569 allowOverwrite) == TCL_ERROR) {
1570 return TCL_ERROR;
1571 }
1572 }
1573 return TCL_OK;
1574 }
1575
1576 /*
1577 *----------------------------------------------------------------------
1578 *
1579 * DoImport --
1580 *
1581 * Import a particular command from one namespace into another. Helper
1582 * for Tcl_Import().
1583 *
1584 * Results:
1585 * Standard Tcl result code. If TCL_ERROR, appends an error message to
1586 * the interpreter result.
1587 *
1588 * Side effects:
1589 * A new command is created in the target namespace unless this is a
1590 * reimport of exactly the same command as before.
1591 *
1592 *----------------------------------------------------------------------
1593 */
1594
1595 static int
DoImport(Tcl_Interp * interp,Namespace * nsPtr,Tcl_HashEntry * hPtr,const char * cmdName,const char * pattern,Namespace * importNsPtr,int allowOverwrite)1596 DoImport(
1597 Tcl_Interp *interp,
1598 Namespace *nsPtr,
1599 Tcl_HashEntry *hPtr,
1600 const char *cmdName,
1601 const char *pattern,
1602 Namespace *importNsPtr,
1603 int allowOverwrite)
1604 {
1605 int i = 0, exported = 0;
1606 Tcl_HashEntry *found;
1607
1608 /*
1609 * The command cmdName in the source namespace matches the pattern. Check
1610 * whether it was exported. If it wasn't, we ignore it.
1611 */
1612
1613 while (!exported && (i < importNsPtr->numExportPatterns)) {
1614 exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
1615 }
1616 if (!exported) {
1617 return TCL_OK;
1618 }
1619
1620 /*
1621 * Unless there is a name clash, create an imported command in the current
1622 * namespace that refers to cmdPtr.
1623 */
1624
1625 found = Tcl_FindHashEntry(&nsPtr->cmdTable, cmdName);
1626 if ((found == NULL) || allowOverwrite) {
1627 /*
1628 * Create the imported command and its client data. To create the new
1629 * command in the current namespace, generate a fully qualified name
1630 * for it.
1631 */
1632
1633 Tcl_DString ds;
1634 Tcl_Command importedCmd;
1635 ImportedCmdData *dataPtr;
1636 Command *cmdPtr;
1637 ImportRef *refPtr;
1638
1639 Tcl_DStringInit(&ds);
1640 Tcl_DStringAppend(&ds, nsPtr->fullName, -1);
1641 if (nsPtr != ((Interp *) interp)->globalNsPtr) {
1642 Tcl_DStringAppend(&ds, "::", 2);
1643 }
1644 Tcl_DStringAppend(&ds, cmdName, -1);
1645
1646 /*
1647 * Check whether creating the new imported command in the current
1648 * namespace would create a cycle of imported command references.
1649 */
1650
1651 cmdPtr = Tcl_GetHashValue(hPtr);
1652 if (found != NULL && cmdPtr->deleteProc == DeleteImportedCmd) {
1653 Command *overwrite = Tcl_GetHashValue(found);
1654 Command *link = cmdPtr;
1655
1656 while (link->deleteProc == DeleteImportedCmd) {
1657 ImportedCmdData *dataPtr = link->objClientData;
1658
1659 link = dataPtr->realCmdPtr;
1660 if (overwrite == link) {
1661 Tcl_AppendResult(interp, "import pattern \"", pattern,
1662 "\" would create a loop containing command \"",
1663 Tcl_DStringValue(&ds), "\"", NULL);
1664 Tcl_DStringFree(&ds);
1665 return TCL_ERROR;
1666 }
1667 }
1668 }
1669
1670 dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
1671 importedCmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
1672 InvokeImportedCmd, dataPtr, DeleteImportedCmd);
1673 dataPtr->realCmdPtr = cmdPtr;
1674 dataPtr->selfPtr = (Command *) importedCmd;
1675 dataPtr->selfPtr->compileProc = cmdPtr->compileProc;
1676 Tcl_DStringFree(&ds);
1677
1678 /*
1679 * Create an ImportRef structure describing this new import command
1680 * and add it to the import ref list in the "real" command.
1681 */
1682
1683 refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
1684 refPtr->importedCmdPtr = (Command *) importedCmd;
1685 refPtr->nextPtr = cmdPtr->importRefPtr;
1686 cmdPtr->importRefPtr = refPtr;
1687 } else {
1688 Command *overwrite = Tcl_GetHashValue(found);
1689
1690 if (overwrite->deleteProc == DeleteImportedCmd) {
1691 ImportedCmdData *dataPtr = overwrite->objClientData;
1692
1693 if (dataPtr->realCmdPtr == Tcl_GetHashValue(hPtr)) {
1694 /*
1695 * Repeated import of same command is acceptable.
1696 */
1697
1698 return TCL_OK;
1699 }
1700 }
1701 Tcl_AppendResult(interp, "can't import command \"", cmdName,
1702 "\": already exists", NULL);
1703 return TCL_ERROR;
1704 }
1705 return TCL_OK;
1706 }
1707
1708 /*
1709 *----------------------------------------------------------------------
1710 *
1711 * Tcl_ForgetImport --
1712 *
1713 * Deletes commands previously imported into the namespace indicated.
1714 * The by namespacePtr, or the current namespace of interp, when
1715 * namespacePtr is NULL. The pattern controls which imported commands are
1716 * deleted. A simple pattern, one without namespace separators, matches
1717 * the current command names of imported commands in the namespace.
1718 * Matching imported commands are deleted. A qualified pattern is
1719 * interpreted as deletion selection on the basis of where the command is
1720 * imported from. The original command and "first link" command for each
1721 * imported command are determined, and they are matched against the
1722 * pattern. A match leads to deletion of the imported command.
1723 *
1724 * Results:
1725 * Returns TCL_ERROR and records an error message in the interp result if
1726 * a namespace qualified pattern refers to a namespace that does not
1727 * exist. Otherwise, returns TCL_OK.
1728 *
1729 * Side effects:
1730 * May delete commands.
1731 *
1732 *----------------------------------------------------------------------
1733 */
1734
1735 int
Tcl_ForgetImport(Tcl_Interp * interp,Tcl_Namespace * namespacePtr,const char * pattern)1736 Tcl_ForgetImport(
1737 Tcl_Interp *interp, /* Current interpreter. */
1738 Tcl_Namespace *namespacePtr,/* Points to the namespace from which
1739 * previously imported commands should be
1740 * removed. NULL for current namespace. */
1741 const char *pattern) /* String pattern indicating which imported
1742 * commands to remove. */
1743 {
1744 Namespace *nsPtr, *sourceNsPtr, *dummyPtr;
1745 const char *simplePattern;
1746 char *cmdName;
1747 register Tcl_HashEntry *hPtr;
1748 Tcl_HashSearch search;
1749
1750 /*
1751 * If the specified namespace is NULL, use the current namespace.
1752 */
1753
1754 if (namespacePtr == NULL) {
1755 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
1756 } else {
1757 nsPtr = (Namespace *) namespacePtr;
1758 }
1759
1760 /*
1761 * Parse the pattern into its namespace-qualification (if any) and the
1762 * simple pattern.
1763 */
1764
1765 TclGetNamespaceForQualName(interp, pattern, nsPtr, TCL_NAMESPACE_ONLY,
1766 &sourceNsPtr, &dummyPtr, &dummyPtr, &simplePattern);
1767
1768 if (sourceNsPtr == NULL) {
1769 Tcl_AppendResult(interp,
1770 "unknown namespace in namespace forget pattern \"",
1771 pattern, "\"", NULL);
1772 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", pattern, NULL);
1773 return TCL_ERROR;
1774 }
1775
1776 if (strcmp(pattern, simplePattern) == 0) {
1777 /*
1778 * The pattern is simple. Delete any imported commands that match it.
1779 */
1780
1781 if (TclMatchIsTrivial(simplePattern)) {
1782 Command *cmdPtr;
1783
1784 hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern);
1785 if ((hPtr != NULL)
1786 && (cmdPtr = Tcl_GetHashValue(hPtr))
1787 && (cmdPtr->deleteProc == DeleteImportedCmd)) {
1788 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1789 }
1790 return TCL_OK;
1791 }
1792 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
1793 (hPtr != NULL); hPtr = Tcl_NextHashEntry(&search)) {
1794 Command *cmdPtr = Tcl_GetHashValue(hPtr);
1795
1796 if (cmdPtr->deleteProc != DeleteImportedCmd) {
1797 continue;
1798 }
1799 cmdName = Tcl_GetHashKey(&nsPtr->cmdTable, hPtr);
1800 if (Tcl_StringMatch(cmdName, simplePattern)) {
1801 Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
1802 }
1803 }
1804 return TCL_OK;
1805 }
1806
1807 /*
1808 * The pattern was namespace-qualified.
1809 */
1810
1811 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); (hPtr != NULL);
1812 hPtr = Tcl_NextHashEntry(&search)) {
1813 Tcl_CmdInfo info;
1814 Tcl_Command token = Tcl_GetHashValue(hPtr);
1815 Tcl_Command origin = TclGetOriginalCommand(token);
1816
1817 if (Tcl_GetCommandInfoFromToken(origin, &info) == 0) {
1818 continue; /* Not an imported command. */
1819 }
1820 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1821 /*
1822 * Original not in namespace we're matching. Check the first link
1823 * in the import chain.
1824 */
1825
1826 Command *cmdPtr = (Command *) token;
1827 ImportedCmdData *dataPtr = cmdPtr->objClientData;
1828 Tcl_Command firstToken = (Tcl_Command) dataPtr->realCmdPtr;
1829
1830 if (firstToken == origin) {
1831 continue;
1832 }
1833 Tcl_GetCommandInfoFromToken(firstToken, &info);
1834 if (info.namespacePtr != (Tcl_Namespace *) sourceNsPtr) {
1835 continue;
1836 }
1837 origin = firstToken;
1838 }
1839 if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
1840 Tcl_DeleteCommandFromToken(interp, token);
1841 }
1842 }
1843 return TCL_OK;
1844 }
1845
1846 /*
1847 *----------------------------------------------------------------------
1848 *
1849 * TclGetOriginalCommand --
1850 *
1851 * An imported command is created in an namespace when a "real" command
1852 * is imported from another namespace. If the specified command is an
1853 * imported command, this function returns the original command it refers
1854 * to.
1855 *
1856 * Results:
1857 * If the command was imported into a sequence of namespaces a, b,...,n
1858 * where each successive namespace just imports the command from the
1859 * previous namespace, this function returns the Tcl_Command token in the
1860 * first namespace, a. Otherwise, if the specified command is not an
1861 * imported command, the function returns NULL.
1862 *
1863 * Side effects:
1864 * None.
1865 *
1866 *----------------------------------------------------------------------
1867 */
1868
1869 Tcl_Command
TclGetOriginalCommand(Tcl_Command command)1870 TclGetOriginalCommand(
1871 Tcl_Command command) /* The imported command for which the original
1872 * command should be returned. */
1873 {
1874 register Command *cmdPtr = (Command *) command;
1875 ImportedCmdData *dataPtr;
1876
1877 if (cmdPtr->deleteProc != DeleteImportedCmd) {
1878 return NULL;
1879 }
1880
1881 while (cmdPtr->deleteProc == DeleteImportedCmd) {
1882 dataPtr = cmdPtr->objClientData;
1883 cmdPtr = dataPtr->realCmdPtr;
1884 }
1885 return (Tcl_Command) cmdPtr;
1886 }
1887
1888 /*
1889 *----------------------------------------------------------------------
1890 *
1891 * InvokeImportedCmd --
1892 *
1893 * Invoked by Tcl whenever the user calls an imported command that was
1894 * created by Tcl_Import. Finds the "real" command (in another
1895 * namespace), and passes control to it.
1896 *
1897 * Results:
1898 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
1899 *
1900 * Side effects:
1901 * Returns a result in the interpreter's result object. If anything goes
1902 * wrong, the result object is set to an error message.
1903 *
1904 *----------------------------------------------------------------------
1905 */
1906
1907 static int
InvokeImportedCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1908 InvokeImportedCmd(
1909 ClientData clientData, /* Points to the imported command's
1910 * ImportedCmdData structure. */
1911 Tcl_Interp *interp, /* Current interpreter. */
1912 int objc, /* Number of arguments. */
1913 Tcl_Obj *const objv[]) /* The argument objects. */
1914 {
1915 register ImportedCmdData *dataPtr = clientData;
1916 register Command *realCmdPtr = dataPtr->realCmdPtr;
1917
1918 return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp,
1919 objc, objv);
1920 }
1921
1922 /*
1923 *----------------------------------------------------------------------
1924 *
1925 * DeleteImportedCmd --
1926 *
1927 * Invoked by Tcl whenever an imported command is deleted. The "real"
1928 * command keeps a list of all the imported commands that refer to it, so
1929 * those imported commands can be deleted when the real command is
1930 * deleted. This function removes the imported command reference from the
1931 * real command's list, and frees up the memory associated with the
1932 * imported command.
1933 *
1934 * Results:
1935 * None.
1936 *
1937 * Side effects:
1938 * Removes the imported command from the real command's import list.
1939 *
1940 *----------------------------------------------------------------------
1941 */
1942
1943 static void
DeleteImportedCmd(ClientData clientData)1944 DeleteImportedCmd(
1945 ClientData clientData) /* Points to the imported command's
1946 * ImportedCmdData structure. */
1947 {
1948 ImportedCmdData *dataPtr = clientData;
1949 Command *realCmdPtr = dataPtr->realCmdPtr;
1950 Command *selfPtr = dataPtr->selfPtr;
1951 register ImportRef *refPtr, *prevPtr;
1952
1953 prevPtr = NULL;
1954 for (refPtr = realCmdPtr->importRefPtr; refPtr != NULL;
1955 refPtr = refPtr->nextPtr) {
1956 if (refPtr->importedCmdPtr == selfPtr) {
1957 /*
1958 * Remove *refPtr from real command's list of imported commands
1959 * that refer to it.
1960 */
1961
1962 if (prevPtr == NULL) { /* refPtr is first in list. */
1963 realCmdPtr->importRefPtr = refPtr->nextPtr;
1964 } else {
1965 prevPtr->nextPtr = refPtr->nextPtr;
1966 }
1967 ckfree((char *) refPtr);
1968 ckfree((char *) dataPtr);
1969 return;
1970 }
1971 prevPtr = refPtr;
1972 }
1973
1974 Tcl_Panic("DeleteImportedCmd: did not find cmd in real cmd's list of import references");
1975 }
1976
1977 /*
1978 *----------------------------------------------------------------------
1979 *
1980 * TclGetNamespaceForQualName --
1981 *
1982 * Given a qualified name specifying a command, variable, or namespace,
1983 * and a namespace in which to resolve the name, this function returns a
1984 * pointer to the namespace that contains the item. A qualified name
1985 * consists of the "simple" name of an item qualified by the names of an
1986 * arbitrary number of containing namespace separated by "::"s. If the
1987 * qualified name starts with "::", it is interpreted absolutely from the
1988 * global namespace. Otherwise, it is interpreted relative to the
1989 * namespace specified by cxtNsPtr if it is non-NULL. If cxtNsPtr is
1990 * NULL, the name is interpreted relative to the current namespace.
1991 *
1992 * A relative name like "foo::bar::x" can be found starting in either the
1993 * current namespace or in the global namespace. So each search usually
1994 * follows two tracks, and two possible namespaces are returned. If the
1995 * function sets either *nsPtrPtr or *altNsPtrPtr to NULL, then that path
1996 * failed.
1997 *
1998 * If "flags" contains TCL_GLOBAL_ONLY, the relative qualified name is
1999 * sought only in the global :: namespace. The alternate search (also)
2000 * starting from the global namespace is ignored and *altNsPtrPtr is set
2001 * NULL.
2002 *
2003 * If "flags" contains TCL_NAMESPACE_ONLY, the relative qualified name is
2004 * sought only in the namespace specified by cxtNsPtr. The alternate
2005 * search starting from the global namespace is ignored and *altNsPtrPtr
2006 * is set NULL. If both TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are
2007 * specified, TCL_GLOBAL_ONLY is ignored and the search starts from the
2008 * namespace specified by cxtNsPtr.
2009 *
2010 * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, all namespace components
2011 * of the qualified name that cannot be found are automatically created
2012 * within their specified parent. This makes sure that functions like
2013 * Tcl_CreateCommand always succeed. There is no alternate search path,
2014 * so *altNsPtrPtr is set NULL.
2015 *
2016 * If "flags" contains TCL_FIND_ONLY_NS, the qualified name is treated as
2017 * a reference to a namespace, and the entire qualified name is followed.
2018 * If the name is relative, the namespace is looked up only in the
2019 * current namespace. A pointer to the namespace is stored in *nsPtrPtr
2020 * and NULL is stored in *simpleNamePtr. Otherwise, if TCL_FIND_ONLY_NS
2021 * is not specified, only the leading components are treated as namespace
2022 * names, and a pointer to the simple name of the final component is
2023 * stored in *simpleNamePtr.
2024 *
2025 * Results:
2026 * It sets *nsPtrPtr and *altNsPtrPtr to point to the two possible
2027 * namespaces which represent the last (containing) namespace in the
2028 * qualified name. If the function sets either *nsPtrPtr or *altNsPtrPtr
2029 * to NULL, then the search along that path failed. The function also
2030 * stores a pointer to the simple name of the final component in
2031 * *simpleNamePtr. If the qualified name is "::" or was treated as a
2032 * namespace reference (TCL_FIND_ONLY_NS), the function stores a pointer
2033 * to the namespace in *nsPtrPtr, NULL in *altNsPtrPtr, and sets
2034 * *simpleNamePtr to point to an empty string.
2035 *
2036 * If there is an error, this function returns TCL_ERROR. If "flags"
2037 * contains TCL_LEAVE_ERR_MSG, an error message is returned in the
2038 * interpreter's result object. Otherwise, the interpreter's result
2039 * object is left unchanged.
2040 *
2041 * *actualCxtPtrPtr is set to the actual context namespace. It is set to
2042 * the input context namespace pointer in cxtNsPtr. If cxtNsPtr is NULL,
2043 * it is set to the current namespace context.
2044 *
2045 * For backwards compatibility with the TclPro byte code loader, this
2046 * function always returns TCL_OK.
2047 *
2048 * Side effects:
2049 * If "flags" contains TCL_CREATE_NS_IF_UNKNOWN, new namespaces may be
2050 * created.
2051 *
2052 *----------------------------------------------------------------------
2053 */
2054
2055 int
TclGetNamespaceForQualName(Tcl_Interp * interp,const char * qualName,Namespace * cxtNsPtr,int flags,Namespace ** nsPtrPtr,Namespace ** altNsPtrPtr,Namespace ** actualCxtPtrPtr,const char ** simpleNamePtr)2056 TclGetNamespaceForQualName(
2057 Tcl_Interp *interp, /* Interpreter in which to find the namespace
2058 * containing qualName. */
2059 const char *qualName, /* A namespace-qualified name of an command,
2060 * variable, or namespace. */
2061 Namespace *cxtNsPtr, /* The namespace in which to start the search
2062 * for qualName's namespace. If NULL start
2063 * from the current namespace. Ignored if
2064 * TCL_GLOBAL_ONLY is set. */
2065 int flags, /* Flags controlling the search: an OR'd
2066 * combination of TCL_GLOBAL_ONLY,
2067 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and
2068 * TCL_CREATE_NS_IF_UNKNOWN. */
2069 Namespace **nsPtrPtr, /* Address where function stores a pointer to
2070 * containing namespace if qualName is found
2071 * starting from *cxtNsPtr or, if
2072 * TCL_GLOBAL_ONLY is set, if qualName is
2073 * found in the global :: namespace. NULL is
2074 * stored otherwise. */
2075 Namespace **altNsPtrPtr, /* Address where function stores a pointer to
2076 * containing namespace if qualName is found
2077 * starting from the global :: namespace.
2078 * NULL is stored if qualName isn't found
2079 * starting from :: or if the TCL_GLOBAL_ONLY,
2080 * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS,
2081 * TCL_CREATE_NS_IF_UNKNOWN flag is set. */
2082 Namespace **actualCxtPtrPtr,/* Address where function stores a pointer to
2083 * the actual namespace from which the search
2084 * started. This is either cxtNsPtr, the ::
2085 * namespace if TCL_GLOBAL_ONLY was specified,
2086 * or the current namespace if cxtNsPtr was
2087 * NULL. */
2088 const char **simpleNamePtr) /* Address where function stores the simple
2089 * name at end of the qualName, or NULL if
2090 * qualName is "::" or the flag
2091 * TCL_FIND_ONLY_NS was specified. */
2092 {
2093 Interp *iPtr = (Interp *) interp;
2094 Namespace *nsPtr = cxtNsPtr;
2095 Namespace *altNsPtr;
2096 Namespace *globalNsPtr = iPtr->globalNsPtr;
2097 const char *start, *end;
2098 const char *nsName;
2099 Tcl_HashEntry *entryPtr;
2100 Tcl_DString buffer;
2101 int len;
2102
2103 /*
2104 * Determine the context namespace nsPtr in which to start the primary
2105 * search. If the qualName name starts with a "::" or TCL_GLOBAL_ONLY was
2106 * specified, search from the global namespace. Otherwise, use the
2107 * namespace given in cxtNsPtr, or if that is NULL, use the current
2108 * namespace context. Note that we always treat two or more adjacent ":"s
2109 * as a namespace separator.
2110 */
2111
2112 if (flags & TCL_GLOBAL_ONLY) {
2113 nsPtr = globalNsPtr;
2114 } else if (nsPtr == NULL) {
2115 nsPtr = iPtr->varFramePtr->nsPtr;
2116 }
2117
2118 start = qualName; /* Points to start of qualifying
2119 * namespace. */
2120 if ((*qualName == ':') && (*(qualName+1) == ':')) {
2121 start = qualName+2; /* Skip over the initial :: */
2122 while (*start == ':') {
2123 start++; /* Skip over a subsequent : */
2124 }
2125 nsPtr = globalNsPtr;
2126 if (*start == '\0') { /* qualName is just two or more
2127 * ":"s. */
2128 *nsPtrPtr = globalNsPtr;
2129 *altNsPtrPtr = NULL;
2130 *actualCxtPtrPtr = globalNsPtr;
2131 *simpleNamePtr = start; /* Points to empty string. */
2132 return TCL_OK;
2133 }
2134 }
2135 *actualCxtPtrPtr = nsPtr;
2136
2137 /*
2138 * Start an alternate search path starting with the global namespace.
2139 * However, if the starting context is the global namespace, or if the
2140 * flag is set to search only the namespace *cxtNsPtr, ignore the
2141 * alternate search path.
2142 */
2143
2144 altNsPtr = globalNsPtr;
2145 if ((nsPtr == globalNsPtr)
2146 || (flags & (TCL_NAMESPACE_ONLY | TCL_FIND_ONLY_NS))) {
2147 altNsPtr = NULL;
2148 }
2149
2150 /*
2151 * Loop to resolve each namespace qualifier in qualName.
2152 */
2153
2154 Tcl_DStringInit(&buffer);
2155 end = start;
2156 while (*start != '\0') {
2157 /*
2158 * Find the next namespace qualifier (i.e., a name ending in "::") or
2159 * the end of the qualified name (i.e., a name ending in "\0"). Set
2160 * len to the number of characters, starting from start, in the name;
2161 * set end to point after the "::"s or at the "\0".
2162 */
2163
2164 len = 0;
2165 for (end = start; *end != '\0'; end++) {
2166 if ((*end == ':') && (*(end+1) == ':')) {
2167 end += 2; /* Skip over the initial :: */
2168 while (*end == ':') {
2169 end++; /* Skip over the subsequent : */
2170 }
2171 break; /* Exit for loop; end is after ::'s */
2172 }
2173 len++;
2174 }
2175
2176 if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) {
2177 /*
2178 * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS
2179 * was specified, look this up as a namespace. Otherwise, start is
2180 * the name of a cmd or var and we are done.
2181 */
2182
2183 if (flags & TCL_FIND_ONLY_NS) {
2184 nsName = start;
2185 } else {
2186 *nsPtrPtr = nsPtr;
2187 *altNsPtrPtr = altNsPtr;
2188 *simpleNamePtr = start;
2189 Tcl_DStringFree(&buffer);
2190 return TCL_OK;
2191 }
2192 } else {
2193 /*
2194 * start points to the beginning of a namespace qualifier ending
2195 * in "::". end points to the start of a name in that namespace
2196 * that might be empty. Copy the namespace qualifier to a buffer
2197 * so it can be null terminated. We can't modify the incoming
2198 * qualName since it may be a string constant.
2199 */
2200
2201 Tcl_DStringSetLength(&buffer, 0);
2202 Tcl_DStringAppend(&buffer, start, len);
2203 nsName = Tcl_DStringValue(&buffer);
2204 }
2205
2206 /*
2207 * Look up the namespace qualifier nsName in the current namespace
2208 * context. If it isn't found but TCL_CREATE_NS_IF_UNKNOWN is set,
2209 * create that qualifying namespace. This is needed for functions like
2210 * Tcl_CreateCommand that cannot fail.
2211 */
2212
2213 if (nsPtr != NULL) {
2214 entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
2215 if (entryPtr != NULL) {
2216 nsPtr = Tcl_GetHashValue(entryPtr);
2217 } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
2218 Tcl_CallFrame *framePtr;
2219
2220 (void) TclPushStackFrame(interp, &framePtr,
2221 (Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
2222
2223 nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
2224 NULL, NULL);
2225 TclPopStackFrame(interp);
2226
2227 if (nsPtr == NULL) {
2228 Tcl_Panic("Could not create namespace '%s'", nsName);
2229 }
2230 } else { /* Namespace not found and was not
2231 * created. */
2232 nsPtr = NULL;
2233 }
2234 }
2235
2236 /*
2237 * Look up the namespace qualifier in the alternate search path too.
2238 */
2239
2240 if (altNsPtr != NULL) {
2241 entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
2242 if (entryPtr != NULL) {
2243 altNsPtr = Tcl_GetHashValue(entryPtr);
2244 } else {
2245 altNsPtr = NULL;
2246 }
2247 }
2248
2249 /*
2250 * If both search paths have failed, return NULL results.
2251 */
2252
2253 if ((nsPtr == NULL) && (altNsPtr == NULL)) {
2254 *nsPtrPtr = NULL;
2255 *altNsPtrPtr = NULL;
2256 *simpleNamePtr = NULL;
2257 Tcl_DStringFree(&buffer);
2258 return TCL_OK;
2259 }
2260
2261 start = end;
2262 }
2263
2264 /*
2265 * We ignore trailing "::"s in a namespace name, but in a command or
2266 * variable name, trailing "::"s refer to the cmd or var named {}.
2267 */
2268
2269 if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) {
2270 *simpleNamePtr = NULL; /* Found namespace name. */
2271 } else {
2272 *simpleNamePtr = end; /* Found cmd/var: points to empty
2273 * string. */
2274 }
2275
2276 /*
2277 * As a special case, if we are looking for a namespace and qualName is ""
2278 * and the current active namespace (nsPtr) is not the global namespace,
2279 * return NULL (no namespace was found). This is because namespaces can
2280 * not have empty names except for the global namespace.
2281 */
2282
2283 if ((flags & TCL_FIND_ONLY_NS) && (*qualName == '\0')
2284 && (nsPtr != globalNsPtr)) {
2285 nsPtr = NULL;
2286 }
2287
2288 *nsPtrPtr = nsPtr;
2289 *altNsPtrPtr = altNsPtr;
2290 Tcl_DStringFree(&buffer);
2291 return TCL_OK;
2292 }
2293
2294 /*
2295 *----------------------------------------------------------------------
2296 *
2297 * Tcl_FindNamespace --
2298 *
2299 * Searches for a namespace.
2300 *
2301 * Results:
2302 * Returns a pointer to the namespace if it is found. Otherwise, returns
2303 * NULL and leaves an error message in the interpreter's result object if
2304 * "flags" contains TCL_LEAVE_ERR_MSG.
2305 *
2306 * Side effects:
2307 * None.
2308 *
2309 *----------------------------------------------------------------------
2310 */
2311
2312 Tcl_Namespace *
Tcl_FindNamespace(Tcl_Interp * interp,const char * name,Tcl_Namespace * contextNsPtr,register int flags)2313 Tcl_FindNamespace(
2314 Tcl_Interp *interp, /* The interpreter in which to find the
2315 * namespace. */
2316 const char *name, /* Namespace name. If it starts with "::",
2317 * will be looked up in global namespace.
2318 * Else, looked up first in contextNsPtr
2319 * (current namespace if contextNsPtr is
2320 * NULL), then in global namespace. */
2321 Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag is set or
2322 * if the name starts with "::". Otherwise,
2323 * points to namespace in which to resolve
2324 * name; if NULL, look up name in the current
2325 * namespace. */
2326 register int flags) /* Flags controlling namespace lookup: an OR'd
2327 * combination of TCL_GLOBAL_ONLY and
2328 * TCL_LEAVE_ERR_MSG flags. */
2329 {
2330 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
2331 const char *dummy;
2332
2333 /*
2334 * Find the namespace(s) that contain the specified namespace name. Add
2335 * the TCL_FIND_ONLY_NS flag to resolve the name all the way down to its
2336 * last component, a namespace.
2337 */
2338
2339 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
2340 flags|TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
2341
2342 if (nsPtr != NULL) {
2343 return (Tcl_Namespace *) nsPtr;
2344 } else if (flags & TCL_LEAVE_ERR_MSG) {
2345 Tcl_ResetResult(interp);
2346 Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", NULL);
2347 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
2348 }
2349 return NULL;
2350 }
2351
2352 /*
2353 *----------------------------------------------------------------------
2354 *
2355 * Tcl_FindCommand --
2356 *
2357 * Searches for a command.
2358 *
2359 * Results:
2360 * Returns a token for the command if it is found. Otherwise, if it can't
2361 * be found or there is an error, returns NULL and leaves an error
2362 * message in the interpreter's result object if "flags" contains
2363 * TCL_LEAVE_ERR_MSG.
2364 *
2365 * Side effects:
2366 * None.
2367 *
2368 *----------------------------------------------------------------------
2369 */
2370
2371 Tcl_Command
Tcl_FindCommand(Tcl_Interp * interp,const char * name,Tcl_Namespace * contextNsPtr,int flags)2372 Tcl_FindCommand(
2373 Tcl_Interp *interp, /* The interpreter in which to find the
2374 * command and to report errors. */
2375 const char *name, /* Command's name. If it starts with "::",
2376 * will be looked up in global namespace.
2377 * Else, looked up first in contextNsPtr
2378 * (current namespace if contextNsPtr is
2379 * NULL), then in global namespace. */
2380 Tcl_Namespace *contextNsPtr,/* Ignored if TCL_GLOBAL_ONLY flag set.
2381 * Otherwise, points to namespace in which to
2382 * resolve name. If NULL, look up name in the
2383 * current namespace. */
2384 int flags) /* An OR'd combination of flags:
2385 * TCL_GLOBAL_ONLY (look up name only in
2386 * global namespace), TCL_NAMESPACE_ONLY (look
2387 * up only in contextNsPtr, or the current
2388 * namespace if contextNsPtr is NULL), and
2389 * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY
2390 * and TCL_NAMESPACE_ONLY are given,
2391 * TCL_GLOBAL_ONLY is ignored. */
2392 {
2393 Interp *iPtr = (Interp *) interp;
2394 Namespace *cxtNsPtr;
2395 register Tcl_HashEntry *entryPtr;
2396 register Command *cmdPtr;
2397 const char *simpleName;
2398 int result;
2399
2400 /*
2401 * If this namespace has a command resolver, then give it first crack at
2402 * the command resolution. If the interpreter has any command resolvers,
2403 * consult them next. The command resolver functions may return a
2404 * Tcl_Command value, they may signal to continue onward, or they may
2405 * signal an error.
2406 */
2407
2408 if ((flags & TCL_GLOBAL_ONLY) || !strncmp(name, "::", 2)) {
2409 cxtNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2410 } else if (contextNsPtr != NULL) {
2411 cxtNsPtr = (Namespace *) contextNsPtr;
2412 } else {
2413 cxtNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
2414 }
2415
2416 if (cxtNsPtr->cmdResProc != NULL || iPtr->resolverPtr != NULL) {
2417 ResolverScheme *resPtr = iPtr->resolverPtr;
2418 Tcl_Command cmd;
2419
2420 if (cxtNsPtr->cmdResProc) {
2421 result = (*cxtNsPtr->cmdResProc)(interp, name,
2422 (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
2423 } else {
2424 result = TCL_CONTINUE;
2425 }
2426
2427 while (result == TCL_CONTINUE && resPtr) {
2428 if (resPtr->cmdResProc) {
2429 result = (*resPtr->cmdResProc)(interp, name,
2430 (Tcl_Namespace *) cxtNsPtr, flags, &cmd);
2431 }
2432 resPtr = resPtr->nextPtr;
2433 }
2434
2435 if (result == TCL_OK) {
2436 return cmd;
2437 } else if (result != TCL_CONTINUE) {
2438 return NULL;
2439 }
2440 }
2441
2442 /*
2443 * Find the namespace(s) that contain the command.
2444 */
2445
2446 cmdPtr = NULL;
2447 if (cxtNsPtr->commandPathLength!=0 && strncmp(name, "::", 2)
2448 && !(flags & TCL_NAMESPACE_ONLY)) {
2449 int i;
2450 Namespace *pathNsPtr, *realNsPtr, *dummyNsPtr;
2451
2452 (void) TclGetNamespaceForQualName(interp, name, cxtNsPtr,
2453 TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2454 &simpleName);
2455 if ((realNsPtr != NULL) && (simpleName != NULL)) {
2456 if ((cxtNsPtr == realNsPtr)
2457 || !(realNsPtr->flags & NS_DYING)) {
2458 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2459 if (entryPtr != NULL) {
2460 cmdPtr = Tcl_GetHashValue(entryPtr);
2461 }
2462 }
2463 }
2464
2465 /*
2466 * Next, check along the path.
2467 */
2468
2469 for (i=0 ; i<cxtNsPtr->commandPathLength && cmdPtr==NULL ; i++) {
2470 pathNsPtr = cxtNsPtr->commandPathArray[i].nsPtr;
2471 if (pathNsPtr == NULL) {
2472 continue;
2473 }
2474 (void) TclGetNamespaceForQualName(interp, name, pathNsPtr,
2475 TCL_NAMESPACE_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2476 &simpleName);
2477 if ((realNsPtr != NULL) && (simpleName != NULL)
2478 && !(realNsPtr->flags & NS_DYING)) {
2479 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2480 if (entryPtr != NULL) {
2481 cmdPtr = Tcl_GetHashValue(entryPtr);
2482 }
2483 }
2484 }
2485
2486 /*
2487 * If we've still not found the command, look in the global namespace
2488 * as a last resort.
2489 */
2490
2491 if (cmdPtr == NULL) {
2492 (void) TclGetNamespaceForQualName(interp, name, NULL,
2493 TCL_GLOBAL_ONLY, &realNsPtr, &dummyNsPtr, &dummyNsPtr,
2494 &simpleName);
2495 if ((realNsPtr != NULL) && (simpleName != NULL)
2496 && !(realNsPtr->flags & NS_DYING)) {
2497 entryPtr = Tcl_FindHashEntry(&realNsPtr->cmdTable, simpleName);
2498 if (entryPtr != NULL) {
2499 cmdPtr = Tcl_GetHashValue(entryPtr);
2500 }
2501 }
2502 }
2503 } else {
2504 Namespace *nsPtr[2];
2505 register int search;
2506
2507 TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr,
2508 flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName);
2509
2510 /*
2511 * Look for the command in the command table of its namespace. Be sure
2512 * to check both possible search paths: from the specified namespace
2513 * context and from the global namespace.
2514 */
2515
2516 for (search = 0; (search < 2) && (cmdPtr == NULL); search++) {
2517 if ((nsPtr[search] != NULL) && (simpleName != NULL)) {
2518 entryPtr = Tcl_FindHashEntry(&nsPtr[search]->cmdTable,
2519 simpleName);
2520 if (entryPtr != NULL) {
2521 cmdPtr = Tcl_GetHashValue(entryPtr);
2522 }
2523 }
2524 }
2525 }
2526
2527 if (cmdPtr != NULL) {
2528 return (Tcl_Command) cmdPtr;
2529 }
2530
2531 if (flags & TCL_LEAVE_ERR_MSG) {
2532 Tcl_ResetResult(interp);
2533 Tcl_AppendResult(interp, "unknown command \"", name, "\"", NULL);
2534 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", name, NULL);
2535 }
2536 return NULL;
2537 }
2538
2539 /*
2540 *----------------------------------------------------------------------
2541 *
2542 * TclResetShadowedCmdRefs --
2543 *
2544 * Called when a command is added to a namespace to check for existing
2545 * command references that the new command may invalidate. Consider the
2546 * following cases that could happen when you add a command "foo" to a
2547 * namespace "b":
2548 * 1. It could shadow a command named "foo" at the global scope. If
2549 * it does, all command references in the namespace "b" are
2550 * suspect.
2551 * 2. Suppose the namespace "b" resides in a namespace "a". Then to
2552 * "a" the new command "b::foo" could shadow another command
2553 * "b::foo" in the global namespace. If so, then all command
2554 * references in "a" * are suspect.
2555 * The same checks are applied to all parent namespaces, until we reach
2556 * the global :: namespace.
2557 *
2558 * Results:
2559 * None.
2560 *
2561 * Side effects:
2562 * If the new command shadows an existing command, the cmdRefEpoch
2563 * counter is incremented in each namespace that sees the shadow. This
2564 * invalidates all command references that were previously cached in that
2565 * namespace. The next time the commands are used, they are resolved from
2566 * scratch.
2567 *
2568 *----------------------------------------------------------------------
2569 */
2570
2571 void
TclResetShadowedCmdRefs(Tcl_Interp * interp,Command * newCmdPtr)2572 TclResetShadowedCmdRefs(
2573 Tcl_Interp *interp, /* Interpreter containing the new command. */
2574 Command *newCmdPtr) /* Points to the new command. */
2575 {
2576 char *cmdName;
2577 Tcl_HashEntry *hPtr;
2578 register Namespace *nsPtr;
2579 Namespace *trailNsPtr, *shadowNsPtr;
2580 Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2581 int found, i;
2582 int trailFront = -1;
2583 int trailSize = 5; /* Formerly NUM_TRAIL_ELEMS. */
2584 Namespace **trailPtr = (Namespace **)
2585 TclStackAlloc(interp, trailSize * sizeof(Namespace *));
2586
2587 /*
2588 * Start at the namespace containing the new command, and work up through
2589 * the list of parents. Stop just before the global namespace, since the
2590 * global namespace can't "shadow" its own entries.
2591 *
2592 * The namespace "trail" list we build consists of the names of each
2593 * namespace that encloses the new command, in order from outermost to
2594 * innermost: for example, "a" then "b". Each iteration of this loop
2595 * eventually extends the trail upwards by one namespace, nsPtr. We use
2596 * this trail list to see if nsPtr (e.g. "a" in 2. above) could have
2597 * now-invalid cached command references. This will happen if nsPtr
2598 * (e.g. "a") contains a sequence of child namespaces (e.g. "b") such that
2599 * there is a identically-named sequence of child namespaces starting from
2600 * :: (e.g. "::b") whose tail namespace contains a command also named
2601 * cmdName.
2602 */
2603
2604 cmdName = Tcl_GetHashKey(newCmdPtr->hPtr->tablePtr, newCmdPtr->hPtr);
2605 for (nsPtr=newCmdPtr->nsPtr ; (nsPtr!=NULL) && (nsPtr!=globalNsPtr) ;
2606 nsPtr=nsPtr->parentPtr) {
2607 /*
2608 * Find the maximal sequence of child namespaces contained in nsPtr
2609 * such that there is a identically-named sequence of child namespaces
2610 * starting from ::. shadowNsPtr will be the tail of this sequence, or
2611 * the deepest namespace under :: that might contain a command now
2612 * shadowed by cmdName. We check below if shadowNsPtr actually
2613 * contains a command cmdName.
2614 */
2615
2616 found = 1;
2617 shadowNsPtr = globalNsPtr;
2618
2619 for (i = trailFront; i >= 0; i--) {
2620 trailNsPtr = trailPtr[i];
2621 hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
2622 trailNsPtr->name);
2623 if (hPtr != NULL) {
2624 shadowNsPtr = Tcl_GetHashValue(hPtr);
2625 } else {
2626 found = 0;
2627 break;
2628 }
2629 }
2630
2631 /*
2632 * If shadowNsPtr contains a command named cmdName, we invalidate all
2633 * of the command refs cached in nsPtr. As a boundary case,
2634 * shadowNsPtr is initially :: and we check for case 1. above.
2635 */
2636
2637 if (found) {
2638 hPtr = Tcl_FindHashEntry(&shadowNsPtr->cmdTable, cmdName);
2639 if (hPtr != NULL) {
2640 nsPtr->cmdRefEpoch++;
2641 TclInvalidateNsPath(nsPtr);
2642
2643 /*
2644 * If the shadowed command was compiled to bytecodes, we
2645 * invalidate all the bytecodes in nsPtr, to force a new
2646 * compilation. We use the resolverEpoch to signal the need
2647 * for a fresh compilation of every bytecode.
2648 */
2649
2650 if (((Command *)Tcl_GetHashValue(hPtr))->compileProc != NULL) {
2651 nsPtr->resolverEpoch++;
2652 }
2653 }
2654 }
2655
2656 /*
2657 * Insert nsPtr at the front of the trail list: i.e., at the end of
2658 * the trailPtr array.
2659 */
2660
2661 trailFront++;
2662 if (trailFront == trailSize) {
2663 int newSize = 2 * trailSize;
2664 trailPtr = (Namespace **) TclStackRealloc(interp,
2665 trailPtr, newSize * sizeof(Namespace *));
2666 trailSize = newSize;
2667 }
2668 trailPtr[trailFront] = nsPtr;
2669 }
2670 TclStackFree(interp, trailPtr);
2671 }
2672
2673 /*
2674 *----------------------------------------------------------------------
2675 *
2676 * TclGetNamespaceFromObj, GetNamespaceFromObj --
2677 *
2678 * Gets the namespace specified by the name in a Tcl_Obj.
2679 *
2680 * Results:
2681 * Returns TCL_OK if the namespace was resolved successfully, and stores
2682 * a pointer to the namespace in the location specified by nsPtrPtr. If
2683 * the namespace can't be found, or anything else goes wrong, this
2684 * function returns TCL_ERROR and writes an error message to interp,
2685 * if non-NULL.
2686 *
2687 * Side effects:
2688 * May update the internal representation for the object, caching the
2689 * namespace reference. The next time this function is called, the
2690 * namespace value can be found quickly.
2691 *
2692 *----------------------------------------------------------------------
2693 */
2694
2695 int
TclGetNamespaceFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_Namespace ** nsPtrPtr)2696 TclGetNamespaceFromObj(
2697 Tcl_Interp *interp, /* The current interpreter. */
2698 Tcl_Obj *objPtr, /* The object to be resolved as the name of a
2699 * namespace. */
2700 Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
2701 {
2702 if (GetNamespaceFromObj(interp, objPtr, nsPtrPtr) == TCL_ERROR) {
2703 const char *name = TclGetString(objPtr);
2704
2705 if ((name[0] == ':') && (name[1] == ':')) {
2706 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2707 "namespace \"%s\" not found", name));
2708 } else {
2709 /*
2710 * Get the current namespace name.
2711 */
2712
2713 NamespaceCurrentCmd(NULL, interp, 2, NULL);
2714 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
2715 "namespace \"%s\" not found in \"%s\"", name,
2716 Tcl_GetStringResult(interp)));
2717 }
2718 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", name, NULL);
2719 return TCL_ERROR;
2720 }
2721 return TCL_OK;
2722 }
2723
2724 static int
GetNamespaceFromObj(Tcl_Interp * interp,Tcl_Obj * objPtr,Tcl_Namespace ** nsPtrPtr)2725 GetNamespaceFromObj(
2726 Tcl_Interp *interp, /* The current interpreter. */
2727 Tcl_Obj *objPtr, /* The object to be resolved as the name of a
2728 * namespace. */
2729 Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */
2730 {
2731 ResolvedNsName *resNamePtr;
2732 Namespace *nsPtr, *refNsPtr;
2733
2734 if (objPtr->typePtr == &nsNameType) {
2735 /*
2736 * Check that the ResolvedNsName is still valid; avoid letting the ref
2737 * cross interps.
2738 */
2739
2740 resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
2741 nsPtr = resNamePtr->nsPtr;
2742 refNsPtr = resNamePtr->refNsPtr;
2743 if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
2744 (!refNsPtr || ((interp == refNsPtr->interp) &&
2745 (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) {
2746 *nsPtrPtr = (Tcl_Namespace *) nsPtr;
2747 return TCL_OK;
2748 }
2749 }
2750 if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
2751 resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
2752 *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
2753 return TCL_OK;
2754 }
2755 return TCL_ERROR;
2756 }
2757
2758 /*
2759 *----------------------------------------------------------------------
2760 *
2761 * Tcl_NamespaceObjCmd --
2762 *
2763 * Invoked to implement the "namespace" command that creates, deletes, or
2764 * manipulates Tcl namespaces. Handles the following syntax:
2765 *
2766 * namespace children ?name? ?pattern?
2767 * namespace code arg
2768 * namespace current
2769 * namespace delete ?name name...?
2770 * namespace ensemble subcommand ?arg...?
2771 * namespace eval name arg ?arg...?
2772 * namespace exists name
2773 * namespace export ?-clear? ?pattern pattern...?
2774 * namespace forget ?pattern pattern...?
2775 * namespace import ?-force? ?pattern pattern...?
2776 * namespace inscope name arg ?arg...?
2777 * namespace origin name
2778 * namespace parent ?name?
2779 * namespace qualifiers string
2780 * namespace tail string
2781 * namespace which ?-command? ?-variable? name
2782 *
2783 * Results:
2784 * Returns TCL_OK if the command is successful. Returns TCL_ERROR if
2785 * anything goes wrong.
2786 *
2787 * Side effects:
2788 * Based on the subcommand name (e.g., "import"), this function
2789 * dispatches to a corresponding function NamespaceXXXCmd defined
2790 * statically in this file. This function's side effects depend on
2791 * whatever that subcommand function does. If there is an error, this
2792 * function returns an error message in the interpreter's result object.
2793 * Otherwise it may return a result in the interpreter's result object.
2794 *
2795 *----------------------------------------------------------------------
2796 */
2797
2798 int
Tcl_NamespaceObjCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2799 Tcl_NamespaceObjCmd(
2800 ClientData clientData, /* Arbitrary value passed to cmd. */
2801 Tcl_Interp *interp, /* Current interpreter. */
2802 int objc, /* Number of arguments. */
2803 Tcl_Obj *const objv[]) /* Argument objects. */
2804 {
2805 static const char *subCmds[] = {
2806 "children", "code", "current", "delete", "ensemble",
2807 "eval", "exists", "export", "forget", "import",
2808 "inscope", "origin", "parent", "path", "qualifiers",
2809 "tail", "unknown", "upvar", "which", NULL
2810 };
2811 enum NSSubCmdIdx {
2812 NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
2813 NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
2814 NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
2815 NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx
2816 };
2817 int index, result;
2818
2819 if (objc < 2) {
2820 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
2821 return TCL_ERROR;
2822 }
2823
2824 /*
2825 * Return an index reflecting the particular subcommand.
2826 */
2827
2828 result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
2829 "option", /*flags*/ 0, (int *) &index);
2830 if (result != TCL_OK) {
2831 return result;
2832 }
2833
2834 switch (index) {
2835 case NSChildrenIdx:
2836 result = NamespaceChildrenCmd(clientData, interp, objc, objv);
2837 break;
2838 case NSCodeIdx:
2839 result = NamespaceCodeCmd(clientData, interp, objc, objv);
2840 break;
2841 case NSCurrentIdx:
2842 result = NamespaceCurrentCmd(clientData, interp, objc, objv);
2843 break;
2844 case NSDeleteIdx:
2845 result = NamespaceDeleteCmd(clientData, interp, objc, objv);
2846 break;
2847 case NSEnsembleIdx:
2848 result = NamespaceEnsembleCmd(clientData, interp, objc, objv);
2849 break;
2850 case NSEvalIdx:
2851 result = NamespaceEvalCmd(clientData, interp, objc, objv);
2852 break;
2853 case NSExistsIdx:
2854 result = NamespaceExistsCmd(clientData, interp, objc, objv);
2855 break;
2856 case NSExportIdx:
2857 result = NamespaceExportCmd(clientData, interp, objc, objv);
2858 break;
2859 case NSForgetIdx:
2860 result = NamespaceForgetCmd(clientData, interp, objc, objv);
2861 break;
2862 case NSImportIdx:
2863 result = NamespaceImportCmd(clientData, interp, objc, objv);
2864 break;
2865 case NSInscopeIdx:
2866 result = NamespaceInscopeCmd(clientData, interp, objc, objv);
2867 break;
2868 case NSOriginIdx:
2869 result = NamespaceOriginCmd(clientData, interp, objc, objv);
2870 break;
2871 case NSParentIdx:
2872 result = NamespaceParentCmd(clientData, interp, objc, objv);
2873 break;
2874 case NSPathIdx:
2875 result = NamespacePathCmd(clientData, interp, objc, objv);
2876 break;
2877 case NSQualifiersIdx:
2878 result = NamespaceQualifiersCmd(clientData, interp, objc, objv);
2879 break;
2880 case NSTailIdx:
2881 result = NamespaceTailCmd(clientData, interp, objc, objv);
2882 break;
2883 case NSUpvarIdx:
2884 result = NamespaceUpvarCmd(clientData, interp, objc, objv);
2885 break;
2886 case NSUnknownIdx:
2887 result = NamespaceUnknownCmd(clientData, interp, objc, objv);
2888 break;
2889 case NSWhichIdx:
2890 result = NamespaceWhichCmd(clientData, interp, objc, objv);
2891 break;
2892 }
2893 return result;
2894 }
2895
2896 /*
2897 *----------------------------------------------------------------------
2898 *
2899 * NamespaceChildrenCmd --
2900 *
2901 * Invoked to implement the "namespace children" command that returns a
2902 * list containing the fully-qualified names of the child namespaces of a
2903 * given namespace. Handles the following syntax:
2904 *
2905 * namespace children ?name? ?pattern?
2906 *
2907 * Results:
2908 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
2909 *
2910 * Side effects:
2911 * Returns a result in the interpreter's result object. If anything goes
2912 * wrong, the result is an error message.
2913 *
2914 *----------------------------------------------------------------------
2915 */
2916
2917 static int
NamespaceChildrenCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])2918 NamespaceChildrenCmd(
2919 ClientData dummy, /* Not used. */
2920 Tcl_Interp *interp, /* Current interpreter. */
2921 int objc, /* Number of arguments. */
2922 Tcl_Obj *const objv[]) /* Argument objects. */
2923 {
2924 Tcl_Namespace *namespacePtr;
2925 Namespace *nsPtr, *childNsPtr;
2926 Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace(interp);
2927 char *pattern = NULL;
2928 Tcl_DString buffer;
2929 register Tcl_HashEntry *entryPtr;
2930 Tcl_HashSearch search;
2931 Tcl_Obj *listPtr, *elemPtr;
2932
2933 /*
2934 * Get a pointer to the specified namespace, or the current namespace.
2935 */
2936
2937 if (objc == 2) {
2938 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
2939 } else if ((objc == 3) || (objc == 4)) {
2940 if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
2941 return TCL_ERROR;
2942 }
2943 nsPtr = (Namespace *) namespacePtr;
2944 } else {
2945 Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
2946 return TCL_ERROR;
2947 }
2948
2949 /*
2950 * Get the glob-style pattern, if any, used to narrow the search.
2951 */
2952
2953 Tcl_DStringInit(&buffer);
2954 if (objc == 4) {
2955 char *name = TclGetString(objv[3]);
2956
2957 if ((*name == ':') && (*(name+1) == ':')) {
2958 pattern = name;
2959 } else {
2960 Tcl_DStringAppend(&buffer, nsPtr->fullName, -1);
2961 if (nsPtr != globalNsPtr) {
2962 Tcl_DStringAppend(&buffer, "::", 2);
2963 }
2964 Tcl_DStringAppend(&buffer, name, -1);
2965 pattern = Tcl_DStringValue(&buffer);
2966 }
2967 }
2968
2969 /*
2970 * Create a list containing the full names of all child namespaces whose
2971 * names match the specified pattern, if any.
2972 */
2973
2974 listPtr = Tcl_NewListObj(0, NULL);
2975 if ((pattern != NULL) && TclMatchIsTrivial(pattern)) {
2976 unsigned int length = strlen(nsPtr->fullName);
2977
2978 if (strncmp(pattern, nsPtr->fullName, length) != 0) {
2979 goto searchDone;
2980 }
2981 if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) {
2982 Tcl_ListObjAppendElement(interp, listPtr,
2983 Tcl_NewStringObj(pattern, -1));
2984 }
2985 goto searchDone;
2986 }
2987 entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
2988 while (entryPtr != NULL) {
2989 childNsPtr = Tcl_GetHashValue(entryPtr);
2990 if ((pattern == NULL)
2991 || Tcl_StringMatch(childNsPtr->fullName, pattern)) {
2992 elemPtr = Tcl_NewStringObj(childNsPtr->fullName, -1);
2993 Tcl_ListObjAppendElement(interp, listPtr, elemPtr);
2994 }
2995 entryPtr = Tcl_NextHashEntry(&search);
2996 }
2997
2998 searchDone:
2999 Tcl_SetObjResult(interp, listPtr);
3000 Tcl_DStringFree(&buffer);
3001 return TCL_OK;
3002 }
3003
3004 /*
3005 *----------------------------------------------------------------------
3006 *
3007 * NamespaceCodeCmd --
3008 *
3009 * Invoked to implement the "namespace code" command to capture the
3010 * namespace context of a command. Handles the following syntax:
3011 *
3012 * namespace code arg
3013 *
3014 * Here "arg" can be a list. "namespace code arg" produces a result
3015 * equivalent to that produced by the command
3016 *
3017 * list ::namespace inscope [namespace current] $arg
3018 *
3019 * However, if "arg" is itself a scoped value starting with "::namespace
3020 * inscope", then the result is just "arg".
3021 *
3022 * Results:
3023 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3024 *
3025 * Side effects:
3026 * If anything goes wrong, this function returns an error message as the
3027 * result in the interpreter's result object.
3028 *
3029 *----------------------------------------------------------------------
3030 */
3031
3032 static int
NamespaceCodeCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3033 NamespaceCodeCmd(
3034 ClientData dummy, /* Not used. */
3035 Tcl_Interp *interp, /* Current interpreter. */
3036 int objc, /* Number of arguments. */
3037 Tcl_Obj *const objv[]) /* Argument objects. */
3038 {
3039 Namespace *currNsPtr;
3040 Tcl_Obj *listPtr, *objPtr;
3041 register char *arg;
3042 int length;
3043
3044 if (objc != 3) {
3045 Tcl_WrongNumArgs(interp, 2, objv, "arg");
3046 return TCL_ERROR;
3047 }
3048
3049 /*
3050 * If "arg" is already a scoped value, then return it directly.
3051 * Take care to only check for scoping in precisely the style that
3052 * [::namespace code] generates it. Anything more forgiving can have
3053 * the effect of failing in namespaces that contain their own custom
3054 " "namespace" command. [Bug 3202171].
3055 */
3056
3057 arg = TclGetStringFromObj(objv[2], &length);
3058 if (*arg==':' && length > 20
3059 && strncmp(arg, "::namespace inscope ", 20) == 0) {
3060 Tcl_SetObjResult(interp, objv[2]);
3061 return TCL_OK;
3062 }
3063
3064 /*
3065 * Otherwise, construct a scoped command by building a list with
3066 * "namespace inscope", the full name of the current namespace, and the
3067 * argument "arg". By constructing a list, we ensure that scoped commands
3068 * are interpreted properly when they are executed later, by the
3069 * "namespace inscope" command.
3070 */
3071
3072 TclNewObj(listPtr);
3073 TclNewLiteralStringObj(objPtr, "::namespace");
3074 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3075 TclNewLiteralStringObj(objPtr, "inscope");
3076 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3077
3078 currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3079 if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
3080 TclNewLiteralStringObj(objPtr, "::");
3081 } else {
3082 objPtr = Tcl_NewStringObj(currNsPtr->fullName, -1);
3083 }
3084 Tcl_ListObjAppendElement(interp, listPtr, objPtr);
3085
3086 Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
3087
3088 Tcl_SetObjResult(interp, listPtr);
3089 return TCL_OK;
3090 }
3091
3092 /*
3093 *----------------------------------------------------------------------
3094 *
3095 * NamespaceCurrentCmd --
3096 *
3097 * Invoked to implement the "namespace current" command which returns the
3098 * fully-qualified name of the current namespace. Handles the following
3099 * syntax:
3100 *
3101 * namespace current
3102 *
3103 * Results:
3104 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3105 *
3106 * Side effects:
3107 * Returns a result in the interpreter's result object. If anything goes
3108 * wrong, the result is an error message.
3109 *
3110 *----------------------------------------------------------------------
3111 */
3112
3113 static int
NamespaceCurrentCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3114 NamespaceCurrentCmd(
3115 ClientData dummy, /* Not used. */
3116 Tcl_Interp *interp, /* Current interpreter. */
3117 int objc, /* Number of arguments. */
3118 Tcl_Obj *const objv[]) /* Argument objects. */
3119 {
3120 register Namespace *currNsPtr;
3121
3122 if (objc != 2) {
3123 Tcl_WrongNumArgs(interp, 2, objv, NULL);
3124 return TCL_ERROR;
3125 }
3126
3127 /*
3128 * The "real" name of the global namespace ("::") is the null string, but
3129 * we return "::" for it as a convenience to programmers. Note that "" and
3130 * "::" are treated as synonyms by the namespace code so that it is still
3131 * easy to do things like:
3132 *
3133 * namespace [namespace current]::bar { ... }
3134 */
3135
3136 currNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3137 if (currNsPtr == (Namespace *) TclGetGlobalNamespace(interp)) {
3138 Tcl_SetObjResult(interp, Tcl_NewStringObj("::", 2));
3139 } else {
3140 Tcl_SetObjResult(interp, Tcl_NewStringObj(currNsPtr->fullName, -1));
3141 }
3142 return TCL_OK;
3143 }
3144
3145 /*
3146 *----------------------------------------------------------------------
3147 *
3148 * NamespaceDeleteCmd --
3149 *
3150 * Invoked to implement the "namespace delete" command to delete
3151 * namespace(s). Handles the following syntax:
3152 *
3153 * namespace delete ?name name...?
3154 *
3155 * Each name identifies a namespace. It may include a sequence of
3156 * namespace qualifiers separated by "::"s. If a namespace is found, it
3157 * is deleted: all variables and procedures contained in that namespace
3158 * are deleted. If that namespace is being used on the call stack, it is
3159 * kept alive (but logically deleted) until it is removed from the call
3160 * stack: that is, it can no longer be referenced by name but any
3161 * currently executing procedure that refers to it is allowed to do so
3162 * until the procedure returns. If the namespace can't be found, this
3163 * function returns an error. If no namespaces are specified, this
3164 * command does nothing.
3165 *
3166 * Results:
3167 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3168 *
3169 * Side effects:
3170 * Deletes the specified namespaces. If anything goes wrong, this
3171 * function returns an error message in the interpreter's result object.
3172 *
3173 *----------------------------------------------------------------------
3174 */
3175
3176 static int
NamespaceDeleteCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3177 NamespaceDeleteCmd(
3178 ClientData dummy, /* Not used. */
3179 Tcl_Interp *interp, /* Current interpreter. */
3180 int objc, /* Number of arguments. */
3181 Tcl_Obj *const objv[]) /* Argument objects. */
3182 {
3183 Tcl_Namespace *namespacePtr;
3184 char *name;
3185 register int i;
3186
3187 if (objc < 2) {
3188 Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
3189 return TCL_ERROR;
3190 }
3191
3192 /*
3193 * Destroying one namespace may cause another to be destroyed. Break this
3194 * into two passes: first check to make sure that all namespaces on the
3195 * command line are valid, and report any errors.
3196 */
3197
3198 for (i = 2; i < objc; i++) {
3199 name = TclGetString(objv[i]);
3200 namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
3201 if ((namespacePtr == NULL)
3202 || (((Namespace *)namespacePtr)->flags & NS_KILLED)) {
3203 Tcl_AppendResult(interp, "unknown namespace \"",
3204 TclGetString(objv[i]),
3205 "\" in namespace delete command", NULL);
3206 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE",
3207 TclGetString(objv[i]), NULL);
3208 return TCL_ERROR;
3209 }
3210 }
3211
3212 /*
3213 * Okay, now delete each namespace.
3214 */
3215
3216 for (i = 2; i < objc; i++) {
3217 name = TclGetString(objv[i]);
3218 namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0);
3219 if (namespacePtr) {
3220 Tcl_DeleteNamespace(namespacePtr);
3221 }
3222 }
3223 return TCL_OK;
3224 }
3225
3226 /*
3227 *----------------------------------------------------------------------
3228 *
3229 * NamespaceEvalCmd --
3230 *
3231 * Invoked to implement the "namespace eval" command. Executes commands
3232 * in a namespace. If the namespace does not already exist, it is
3233 * created. Handles the following syntax:
3234 *
3235 * namespace eval name arg ?arg...?
3236 *
3237 * If more than one arg argument is specified, the command that is
3238 * executed is the result of concatenating the arguments together with a
3239 * space between each argument.
3240 *
3241 * Results:
3242 * Returns TCL_OK if the namespace is found and the commands are executed
3243 * successfully. Returns TCL_ERROR if anything goes wrong.
3244 *
3245 * Side effects:
3246 * Returns the result of the command in the interpreter's result object.
3247 * If anything goes wrong, this function returns an error message as the
3248 * result.
3249 *
3250 *----------------------------------------------------------------------
3251 */
3252
3253 static int
NamespaceEvalCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3254 NamespaceEvalCmd(
3255 ClientData dummy, /* Not used. */
3256 Tcl_Interp *interp, /* Current interpreter. */
3257 int objc, /* Number of arguments. */
3258 Tcl_Obj *const objv[]) /* Argument objects. */
3259 {
3260 Tcl_Namespace *namespacePtr;
3261 CallFrame *framePtr, **framePtrPtr;
3262 Tcl_Obj *objPtr;
3263 int result;
3264
3265 if (objc < 4) {
3266 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
3267 return TCL_ERROR;
3268 }
3269
3270 /*
3271 * Try to resolve the namespace reference, caching the result in the
3272 * namespace object along the way.
3273 */
3274
3275 result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
3276
3277 /*
3278 * If the namespace wasn't found, try to create it.
3279 */
3280
3281 if (result == TCL_ERROR) {
3282 char *name = TclGetString(objv[2]);
3283
3284 namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL);
3285 if (namespacePtr == NULL) {
3286 return TCL_ERROR;
3287 }
3288 }
3289
3290 /*
3291 * Make the specified namespace the current namespace and evaluate the
3292 * command(s).
3293 */
3294
3295 /* This is needed to satisfy GCC 3.3's strict aliasing rules */
3296 framePtrPtr = &framePtr;
3297 result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
3298 namespacePtr, /*isProcCallFrame*/ 0);
3299 if (result != TCL_OK) {
3300 return TCL_ERROR;
3301 }
3302
3303 framePtr->objc = objc;
3304 framePtr->objv = objv;
3305
3306 if (objc == 4) {
3307 /*
3308 * TIP #280: Make actual argument location available to eval'd script.
3309 */
3310
3311 Interp *iPtr = (Interp *) interp;
3312 CmdFrame* invoker = iPtr->cmdFramePtr;
3313 int word = 3;
3314
3315 TclArgumentGet (interp, objv[3], &invoker, &word);
3316 result = TclEvalObjEx(interp, objv[3], 0, invoker, word);
3317 } else {
3318 /*
3319 * More than one argument: concatenate them together with spaces
3320 * between, then evaluate the result. Tcl_EvalObjEx will delete the
3321 * object when it decrements its refcount after eval'ing it.
3322 */
3323
3324 objPtr = Tcl_ConcatObj(objc-3, objv+3);
3325
3326 /*
3327 * TIP #280: Make invoking context available to eval'd script.
3328 */
3329
3330 result = TclEvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, 0);
3331 }
3332
3333 if (result == TCL_ERROR) {
3334 int length = strlen(namespacePtr->fullName);
3335 int limit = 200;
3336 int overflow = (length > limit);
3337
3338 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
3339 "\n (in namespace eval \"%.*s%s\" script line %d)",
3340 (overflow ? limit : length), namespacePtr->fullName,
3341 (overflow ? "..." : ""), interp->errorLine));
3342 }
3343
3344 /*
3345 * Restore the previous "current" namespace.
3346 */
3347
3348 TclPopStackFrame(interp);
3349 return result;
3350 }
3351
3352 /*
3353 *----------------------------------------------------------------------
3354 *
3355 * NamespaceExistsCmd --
3356 *
3357 * Invoked to implement the "namespace exists" command that returns true
3358 * if the given namespace currently exists, and false otherwise. Handles
3359 * the following syntax:
3360 *
3361 * namespace exists name
3362 *
3363 * Results:
3364 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3365 *
3366 * Side effects:
3367 * Returns a result in the interpreter's result object. If anything goes
3368 * wrong, the result is an error message.
3369 *
3370 *----------------------------------------------------------------------
3371 */
3372
3373 static int
NamespaceExistsCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3374 NamespaceExistsCmd(
3375 ClientData dummy, /* Not used. */
3376 Tcl_Interp *interp, /* Current interpreter. */
3377 int objc, /* Number of arguments. */
3378 Tcl_Obj *const objv[]) /* Argument objects. */
3379 {
3380 Tcl_Namespace *namespacePtr;
3381
3382 if (objc != 3) {
3383 Tcl_WrongNumArgs(interp, 2, objv, "name");
3384 return TCL_ERROR;
3385 }
3386
3387 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
3388 GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK));
3389 return TCL_OK;
3390 }
3391
3392 /*
3393 *----------------------------------------------------------------------
3394 *
3395 * NamespaceExportCmd --
3396 *
3397 * Invoked to implement the "namespace export" command that specifies
3398 * which commands are exported from a namespace. The exported commands
3399 * are those that can be imported into another namespace using "namespace
3400 * import". Both commands defined in a namespace and commands the
3401 * namespace has imported can be exported by a namespace. This command
3402 * has the following syntax:
3403 *
3404 * namespace export ?-clear? ?pattern pattern...?
3405 *
3406 * Each pattern may contain "string match"-style pattern matching special
3407 * characters, but the pattern may not include any namespace qualifiers:
3408 * that is, the pattern must specify commands in the current (exporting)
3409 * namespace. The specified patterns are appended onto the namespace's
3410 * list of export patterns.
3411 *
3412 * To reset the namespace's export pattern list, specify the "-clear"
3413 * flag.
3414 *
3415 * If there are no export patterns and the "-clear" flag isn't given,
3416 * this command returns the namespace's current export list.
3417 *
3418 * Results:
3419 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3420 *
3421 * Side effects:
3422 * Returns a result in the interpreter's result object. If anything goes
3423 * wrong, the result is an error message.
3424 *
3425 *----------------------------------------------------------------------
3426 */
3427
3428 static int
NamespaceExportCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3429 NamespaceExportCmd(
3430 ClientData dummy, /* Not used. */
3431 Tcl_Interp *interp, /* Current interpreter. */
3432 int objc, /* Number of arguments. */
3433 Tcl_Obj *const objv[]) /* Argument objects. */
3434 {
3435 int firstArg, i;
3436
3437 if (objc < 2) {
3438 Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?");
3439 return TCL_ERROR;
3440 }
3441
3442 /*
3443 * If no pattern arguments are given, and "-clear" isn't specified, return
3444 * the namespace's current export pattern list.
3445 */
3446
3447 if (objc == 2) {
3448 Tcl_Obj *listPtr = Tcl_NewObj();
3449
3450 (void) Tcl_AppendExportList(interp, NULL, listPtr);
3451 Tcl_SetObjResult(interp, listPtr);
3452 return TCL_OK;
3453 }
3454
3455 /*
3456 * Process the optional "-clear" argument.
3457 */
3458
3459 firstArg = 2;
3460 if (strcmp("-clear", Tcl_GetString(objv[firstArg])) == 0) {
3461 Tcl_Export(interp, NULL, "::", 1);
3462 Tcl_ResetResult(interp);
3463 firstArg++;
3464 }
3465
3466 /*
3467 * Add each pattern to the namespace's export pattern list.
3468 */
3469
3470 for (i = firstArg; i < objc; i++) {
3471 int result = Tcl_Export(interp, NULL, Tcl_GetString(objv[i]), 0);
3472 if (result != TCL_OK) {
3473 return result;
3474 }
3475 }
3476 return TCL_OK;
3477 }
3478
3479 /*
3480 *----------------------------------------------------------------------
3481 *
3482 * NamespaceForgetCmd --
3483 *
3484 * Invoked to implement the "namespace forget" command to remove imported
3485 * commands from a namespace. Handles the following syntax:
3486 *
3487 * namespace forget ?pattern pattern...?
3488 *
3489 * Each pattern is a name like "foo::*" or "a::b::x*". That is, the
3490 * pattern may include the special pattern matching characters recognized
3491 * by the "string match" command, but only in the command name at the end
3492 * of the qualified name; the special pattern characters may not appear
3493 * in a namespace name. All of the commands that match that pattern are
3494 * checked to see if they have an imported command in the current
3495 * namespace that refers to the matched command. If there is an alias, it
3496 * is removed.
3497 *
3498 * Results:
3499 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3500 *
3501 * Side effects:
3502 * Imported commands are removed from the current namespace. If anything
3503 * goes wrong, this function returns an error message in the
3504 * interpreter's result object.
3505 *
3506 *----------------------------------------------------------------------
3507 */
3508
3509 static int
NamespaceForgetCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3510 NamespaceForgetCmd(
3511 ClientData dummy, /* Not used. */
3512 Tcl_Interp *interp, /* Current interpreter. */
3513 int objc, /* Number of arguments. */
3514 Tcl_Obj *const objv[]) /* Argument objects. */
3515 {
3516 char *pattern;
3517 register int i, result;
3518
3519 if (objc < 2) {
3520 Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
3521 return TCL_ERROR;
3522 }
3523
3524 for (i = 2; i < objc; i++) {
3525 pattern = TclGetString(objv[i]);
3526 result = Tcl_ForgetImport(interp, NULL, pattern);
3527 if (result != TCL_OK) {
3528 return result;
3529 }
3530 }
3531 return TCL_OK;
3532 }
3533
3534 /*
3535 *----------------------------------------------------------------------
3536 *
3537 * NamespaceImportCmd --
3538 *
3539 * Invoked to implement the "namespace import" command that imports
3540 * commands into a namespace. Handles the following syntax:
3541 *
3542 * namespace import ?-force? ?pattern pattern...?
3543 *
3544 * Each pattern is a namespace-qualified name like "foo::*", "a::b::x*",
3545 * or "bar::p". That is, the pattern may include the special pattern
3546 * matching characters recognized by the "string match" command, but only
3547 * in the command name at the end of the qualified name; the special
3548 * pattern characters may not appear in a namespace name. All of the
3549 * commands that match the pattern and which are exported from their
3550 * namespace are made accessible from the current namespace context. This
3551 * is done by creating a new "imported command" in the current namespace
3552 * that points to the real command in its original namespace; when the
3553 * imported command is called, it invokes the real command.
3554 *
3555 * If an imported command conflicts with an existing command, it is
3556 * treated as an error. But if the "-force" option is included, then
3557 * existing commands are overwritten by the imported commands.
3558 *
3559 * If there are no pattern arguments and the "-force" flag isn't given,
3560 * this command returns the list of commands currently imported in
3561 * the current namespace.
3562 *
3563 * Results:
3564 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3565 *
3566 * Side effects:
3567 * Adds imported commands to the current namespace. If anything goes
3568 * wrong, this function returns an error message in the interpreter's
3569 * result object.
3570 *
3571 *----------------------------------------------------------------------
3572 */
3573
3574 static int
NamespaceImportCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3575 NamespaceImportCmd(
3576 ClientData dummy, /* Not used. */
3577 Tcl_Interp *interp, /* Current interpreter. */
3578 int objc, /* Number of arguments. */
3579 Tcl_Obj *const objv[]) /* Argument objects. */
3580 {
3581 int allowOverwrite = 0;
3582 char *string, *pattern;
3583 register int i, result;
3584 int firstArg;
3585
3586 if (objc < 2) {
3587 Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?");
3588 return TCL_ERROR;
3589 }
3590
3591 /*
3592 * Skip over the optional "-force" as the first argument.
3593 */
3594
3595 firstArg = 2;
3596 if (firstArg < objc) {
3597 string = TclGetString(objv[firstArg]);
3598 if ((*string == '-') && (strcmp(string, "-force") == 0)) {
3599 allowOverwrite = 1;
3600 firstArg++;
3601 }
3602 } else {
3603 /*
3604 * When objc == 2, command is just [namespace import]. Introspection
3605 * form to return list of imported commands.
3606 */
3607
3608 Tcl_HashEntry *hPtr;
3609 Tcl_HashSearch search;
3610 Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3611 Tcl_Obj *listPtr;
3612
3613 TclNewObj(listPtr);
3614 for (hPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
3615 hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
3616 Command *cmdPtr = Tcl_GetHashValue(hPtr);
3617
3618 if (cmdPtr->deleteProc == DeleteImportedCmd) {
3619 Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewStringObj(
3620 Tcl_GetHashKey(&nsPtr->cmdTable, hPtr) ,-1));
3621 }
3622 }
3623 Tcl_SetObjResult(interp, listPtr);
3624 return TCL_OK;
3625 }
3626
3627 /*
3628 * Handle the imports for each of the patterns.
3629 */
3630
3631 for (i = firstArg; i < objc; i++) {
3632 pattern = TclGetString(objv[i]);
3633 result = Tcl_Import(interp, NULL, pattern, allowOverwrite);
3634 if (result != TCL_OK) {
3635 return result;
3636 }
3637 }
3638 return TCL_OK;
3639 }
3640
3641 /*
3642 *----------------------------------------------------------------------
3643 *
3644 * NamespaceInscopeCmd --
3645 *
3646 * Invoked to implement the "namespace inscope" command that executes a
3647 * script in the context of a particular namespace. This command is not
3648 * expected to be used directly by programmers; calls to it are generated
3649 * implicitly when programs use "namespace code" commands to register
3650 * callback scripts. Handles the following syntax:
3651 *
3652 * namespace inscope name arg ?arg...?
3653 *
3654 * The "namespace inscope" command is much like the "namespace eval"
3655 * command except that it has lappend semantics and the namespace must
3656 * already exist. It treats the first argument as a list, and appends any
3657 * arguments after the first onto the end as proper list elements. For
3658 * example,
3659 *
3660 * namespace inscope ::foo {a b} c d e
3661 *
3662 * is equivalent to
3663 *
3664 * namespace eval ::foo [concat {a b} [list c d e]]
3665 *
3666 * This lappend semantics is important because many callback scripts are
3667 * actually prefixes.
3668 *
3669 * Results:
3670 * Returns TCL_OK to indicate success, or TCL_ERROR to indicate failure.
3671 *
3672 * Side effects:
3673 * Returns a result in the Tcl interpreter's result object.
3674 *
3675 *----------------------------------------------------------------------
3676 */
3677
3678 static int
NamespaceInscopeCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3679 NamespaceInscopeCmd(
3680 ClientData dummy, /* Not used. */
3681 Tcl_Interp *interp, /* Current interpreter. */
3682 int objc, /* Number of arguments. */
3683 Tcl_Obj *const objv[]) /* Argument objects. */
3684 {
3685 Tcl_Namespace *namespacePtr;
3686 CallFrame *framePtr, **framePtrPtr;
3687 int i, result;
3688
3689 if (objc < 4) {
3690 Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
3691 return TCL_ERROR;
3692 }
3693
3694 /*
3695 * Resolve the namespace reference.
3696 */
3697
3698 if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
3699 return TCL_ERROR;
3700 }
3701
3702 /*
3703 * Make the specified namespace the current namespace.
3704 */
3705
3706 framePtrPtr = &framePtr; /* This is needed to satisfy GCC's
3707 * strict aliasing rules. */
3708 result = TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
3709 namespacePtr, /*isProcCallFrame*/ 0);
3710 if (result != TCL_OK) {
3711 return result;
3712 }
3713
3714 framePtr->objc = objc;
3715 framePtr->objv = objv;
3716
3717 /*
3718 * Execute the command. If there is just one argument, just treat it as a
3719 * script and evaluate it. Otherwise, create a list from the arguments
3720 * after the first one, then concatenate the first argument and the list
3721 * of extra arguments to form the command to evaluate.
3722 */
3723
3724 if (objc == 4) {
3725 result = Tcl_EvalObjEx(interp, objv[3], 0);
3726 } else {
3727 Tcl_Obj *concatObjv[2];
3728 register Tcl_Obj *listPtr, *cmdObjPtr;
3729
3730 listPtr = Tcl_NewListObj(0, NULL);
3731 for (i = 4; i < objc; i++) {
3732 if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) {
3733 Tcl_DecrRefCount(listPtr); /* Free unneeded obj. */
3734 return TCL_ERROR;
3735 }
3736 }
3737
3738 concatObjv[0] = objv[3];
3739 concatObjv[1] = listPtr;
3740 cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
3741 result = Tcl_EvalObjEx(interp, cmdObjPtr, TCL_EVAL_DIRECT);
3742 Tcl_DecrRefCount(listPtr); /* We're done with the list object. */
3743 }
3744
3745 if (result == TCL_ERROR) {
3746 int length = strlen(namespacePtr->fullName);
3747 int limit = 200;
3748 int overflow = (length > limit);
3749
3750 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
3751 "\n (in namespace inscope \"%.*s%s\" script line %d)",
3752 (overflow ? limit : length), namespacePtr->fullName,
3753 (overflow ? "..." : ""), interp->errorLine));
3754 }
3755
3756 /*
3757 * Restore the previous "current" namespace.
3758 */
3759
3760 TclPopStackFrame(interp);
3761 return result;
3762 }
3763
3764 /*
3765 *----------------------------------------------------------------------
3766 *
3767 * NamespaceOriginCmd --
3768 *
3769 * Invoked to implement the "namespace origin" command to return the
3770 * fully-qualified name of the "real" command to which the specified
3771 * "imported command" refers. Handles the following syntax:
3772 *
3773 * namespace origin name
3774 *
3775 * Results:
3776 * An imported command is created in an namespace when that namespace
3777 * imports a command from another namespace. If a command is imported
3778 * into a sequence of namespaces a, b,...,n where each successive
3779 * namespace just imports the command from the previous namespace, this
3780 * command returns the fully-qualified name of the original command in
3781 * the first namespace, a. If "name" does not refer to an alias, its
3782 * fully-qualified name is returned. The returned name is stored in the
3783 * interpreter's result object. This function returns TCL_OK if
3784 * successful, and TCL_ERROR if anything goes wrong.
3785 *
3786 * Side effects:
3787 * If anything goes wrong, this function returns an error message in the
3788 * interpreter's result object.
3789 *
3790 *----------------------------------------------------------------------
3791 */
3792
3793 static int
NamespaceOriginCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3794 NamespaceOriginCmd(
3795 ClientData dummy, /* Not used. */
3796 Tcl_Interp *interp, /* Current interpreter. */
3797 int objc, /* Number of arguments. */
3798 Tcl_Obj *const objv[]) /* Argument objects. */
3799 {
3800 Tcl_Command command, origCommand;
3801 Tcl_Obj *resultPtr;
3802
3803 if (objc != 3) {
3804 Tcl_WrongNumArgs(interp, 2, objv, "name");
3805 return TCL_ERROR;
3806 }
3807
3808 command = Tcl_GetCommandFromObj(interp, objv[2]);
3809 if (command == NULL) {
3810 Tcl_AppendResult(interp, "invalid command name \"",
3811 TclGetString(objv[2]), "\"", NULL);
3812 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
3813 TclGetString(objv[2]), NULL);
3814 return TCL_ERROR;
3815 }
3816 origCommand = TclGetOriginalCommand(command);
3817 TclNewObj(resultPtr);
3818 if (origCommand == NULL) {
3819 /*
3820 * The specified command isn't an imported command. Return the
3821 * command's name qualified by the full name of the namespace it was
3822 * defined in.
3823 */
3824
3825 Tcl_GetCommandFullName(interp, command, resultPtr);
3826 } else {
3827 Tcl_GetCommandFullName(interp, origCommand, resultPtr);
3828 }
3829 Tcl_SetObjResult(interp, resultPtr);
3830 return TCL_OK;
3831 }
3832
3833 /*
3834 *----------------------------------------------------------------------
3835 *
3836 * NamespaceParentCmd --
3837 *
3838 * Invoked to implement the "namespace parent" command that returns the
3839 * fully-qualified name of the parent namespace for a specified
3840 * namespace. Handles the following syntax:
3841 *
3842 * namespace parent ?name?
3843 *
3844 * Results:
3845 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
3846 *
3847 * Side effects:
3848 * Returns a result in the interpreter's result object. If anything goes
3849 * wrong, the result is an error message.
3850 *
3851 *----------------------------------------------------------------------
3852 */
3853
3854 static int
NamespaceParentCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3855 NamespaceParentCmd(
3856 ClientData dummy, /* Not used. */
3857 Tcl_Interp *interp, /* Current interpreter. */
3858 int objc, /* Number of arguments. */
3859 Tcl_Obj *const objv[]) /* Argument objects. */
3860 {
3861 Tcl_Namespace *nsPtr;
3862
3863 if (objc == 2) {
3864 nsPtr = TclGetCurrentNamespace(interp);
3865 } else if (objc == 3) {
3866 if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
3867 return TCL_ERROR;
3868 }
3869 } else {
3870 Tcl_WrongNumArgs(interp, 2, objv, "?name?");
3871 return TCL_ERROR;
3872 }
3873
3874 /*
3875 * Report the parent of the specified namespace.
3876 */
3877
3878 if (nsPtr->parentPtr != NULL) {
3879 Tcl_SetObjResult(interp, Tcl_NewStringObj(
3880 nsPtr->parentPtr->fullName, -1));
3881 }
3882 return TCL_OK;
3883 }
3884
3885 /*
3886 *----------------------------------------------------------------------
3887 *
3888 * NamespacePathCmd --
3889 *
3890 * Invoked to implement the "namespace path" command that reads and
3891 * writes the current namespace's command resolution path. Has one
3892 * optional argument: if present, it is a list of named namespaces to set
3893 * the path to, and if absent, the current path should be returned.
3894 * Handles the following syntax:
3895 *
3896 * namespace path ?nsList?
3897 *
3898 * Results:
3899 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong
3900 * (most notably if the namespace list contains the name of something
3901 * other than a namespace). In the successful-exit case, may set the
3902 * interpreter result to the list of names of the namespaces on the
3903 * current namespace's path.
3904 *
3905 * Side effects:
3906 * May update the namespace path (triggering a recomputing of all command
3907 * names that depend on the namespace for resolution).
3908 *
3909 *----------------------------------------------------------------------
3910 */
3911
3912 static int
NamespacePathCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])3913 NamespacePathCmd(
3914 ClientData dummy, /* Not used. */
3915 Tcl_Interp *interp, /* Current interpreter. */
3916 int objc, /* Number of arguments. */
3917 Tcl_Obj *const objv[]) /* Argument objects. */
3918 {
3919 Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
3920 int i, nsObjc, result = TCL_ERROR;
3921 Tcl_Obj **nsObjv;
3922 Tcl_Namespace **namespaceList = NULL;
3923
3924 if (objc > 3) {
3925 Tcl_WrongNumArgs(interp, 2, objv, "?pathList?");
3926 return TCL_ERROR;
3927 }
3928
3929 /*
3930 * If no path is given, return the current path.
3931 */
3932
3933 if (objc == 2) {
3934 /*
3935 * Not a very fast way to compute this, but easy to get right.
3936 */
3937
3938 for (i=0 ; i<nsPtr->commandPathLength ; i++) {
3939 if (nsPtr->commandPathArray[i].nsPtr != NULL) {
3940 Tcl_AppendElement(interp,
3941 nsPtr->commandPathArray[i].nsPtr->fullName);
3942 }
3943 }
3944 return TCL_OK;
3945 }
3946
3947 /*
3948 * There is a path given, so parse it into an array of namespace pointers.
3949 */
3950
3951 if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
3952 goto badNamespace;
3953 }
3954 if (nsObjc != 0) {
3955 namespaceList = (Tcl_Namespace **)
3956 TclStackAlloc(interp, sizeof(Tcl_Namespace *) * nsObjc);
3957
3958 for (i=0 ; i<nsObjc ; i++) {
3959 if (TclGetNamespaceFromObj(interp, nsObjv[i],
3960 &namespaceList[i]) != TCL_OK) {
3961 goto badNamespace;
3962 }
3963 }
3964 }
3965
3966 /*
3967 * Now we have the list of valid namespaces, install it as the path.
3968 */
3969
3970 TclSetNsPath(nsPtr, nsObjc, namespaceList);
3971
3972 result = TCL_OK;
3973 badNamespace:
3974 if (namespaceList != NULL) {
3975 TclStackFree(interp, namespaceList);
3976 }
3977 return result;
3978 }
3979
3980 /*
3981 *----------------------------------------------------------------------
3982 *
3983 * TclSetNsPath --
3984 *
3985 * Sets the namespace command name resolution path to the given list of
3986 * namespaces. If the list is empty (of zero length) the path is set to
3987 * empty and the default old-style behaviour of command name resolution
3988 * is used.
3989 *
3990 * Results:
3991 * nothing
3992 *
3993 * Side effects:
3994 * Invalidates the command name resolution caches for any command
3995 * resolved in the given namespace.
3996 *
3997 *----------------------------------------------------------------------
3998 */
3999
4000 void
TclSetNsPath(Namespace * nsPtr,int pathLength,Tcl_Namespace * pathAry[])4001 TclSetNsPath(
4002 Namespace *nsPtr, /* Namespace whose path is to be set. */
4003 int pathLength, /* Length of pathAry. */
4004 Tcl_Namespace *pathAry[]) /* Array of namespaces that are the path. */
4005 {
4006 if (pathLength != 0) {
4007 NamespacePathEntry *tmpPathArray = (NamespacePathEntry *)
4008 ckalloc(sizeof(NamespacePathEntry) * pathLength);
4009 int i;
4010
4011 for (i=0 ; i<pathLength ; i++) {
4012 tmpPathArray[i].nsPtr = (Namespace *) pathAry[i];
4013 tmpPathArray[i].creatorNsPtr = nsPtr;
4014 tmpPathArray[i].prevPtr = NULL;
4015 tmpPathArray[i].nextPtr =
4016 tmpPathArray[i].nsPtr->commandPathSourceList;
4017 if (tmpPathArray[i].nextPtr != NULL) {
4018 tmpPathArray[i].nextPtr->prevPtr = &tmpPathArray[i];
4019 }
4020 tmpPathArray[i].nsPtr->commandPathSourceList = &tmpPathArray[i];
4021 }
4022 if (nsPtr->commandPathLength != 0) {
4023 UnlinkNsPath(nsPtr);
4024 }
4025 nsPtr->commandPathArray = tmpPathArray;
4026 } else {
4027 if (nsPtr->commandPathLength != 0) {
4028 UnlinkNsPath(nsPtr);
4029 }
4030 }
4031
4032 nsPtr->commandPathLength = pathLength;
4033 nsPtr->cmdRefEpoch++;
4034 nsPtr->resolverEpoch++;
4035 }
4036
4037 /*
4038 *----------------------------------------------------------------------
4039 *
4040 * UnlinkNsPath --
4041 *
4042 * Delete the given namespace's command name resolution path. Only call
4043 * if the path is non-empty. Caller must reset the counter containing the
4044 * path size.
4045 *
4046 * Results:
4047 * nothing
4048 *
4049 * Side effects:
4050 * Deletes the array of path entries and unlinks those path entries from
4051 * the target namespace's list of interested namespaces.
4052 *
4053 *----------------------------------------------------------------------
4054 */
4055
4056 static void
UnlinkNsPath(Namespace * nsPtr)4057 UnlinkNsPath(
4058 Namespace *nsPtr)
4059 {
4060 int i;
4061 for (i=0 ; i<nsPtr->commandPathLength ; i++) {
4062 NamespacePathEntry *nsPathPtr = &nsPtr->commandPathArray[i];
4063 if (nsPathPtr->prevPtr != NULL) {
4064 nsPathPtr->prevPtr->nextPtr = nsPathPtr->nextPtr;
4065 }
4066 if (nsPathPtr->nextPtr != NULL) {
4067 nsPathPtr->nextPtr->prevPtr = nsPathPtr->prevPtr;
4068 }
4069 if (nsPathPtr->nsPtr != NULL) {
4070 if (nsPathPtr->nsPtr->commandPathSourceList == nsPathPtr) {
4071 nsPathPtr->nsPtr->commandPathSourceList = nsPathPtr->nextPtr;
4072 }
4073 }
4074 }
4075 ckfree((char *) nsPtr->commandPathArray);
4076 }
4077
4078 /*
4079 *----------------------------------------------------------------------
4080 *
4081 * TclInvalidateNsPath --
4082 *
4083 * Invalidate the name resolution caches for all names looked up in
4084 * namespaces whose name path includes the given namespace.
4085 *
4086 * Results:
4087 * nothing
4088 *
4089 * Side effects:
4090 * Increments the command reference epoch in each namespace whose path
4091 * includes the given namespace. This causes any cached resolved names
4092 * whose root cacheing context starts at that namespace to be recomputed
4093 * the next time they are used.
4094 *
4095 *----------------------------------------------------------------------
4096 */
4097
4098 void
TclInvalidateNsPath(Namespace * nsPtr)4099 TclInvalidateNsPath(
4100 Namespace *nsPtr)
4101 {
4102 NamespacePathEntry *nsPathPtr = nsPtr->commandPathSourceList;
4103 while (nsPathPtr != NULL) {
4104 if (nsPathPtr->nsPtr != NULL) {
4105 nsPathPtr->creatorNsPtr->cmdRefEpoch++;
4106 }
4107 nsPathPtr = nsPathPtr->nextPtr;
4108 }
4109 }
4110
4111 /*
4112 *----------------------------------------------------------------------
4113 *
4114 * NamespaceQualifiersCmd --
4115 *
4116 * Invoked to implement the "namespace qualifiers" command that returns
4117 * any leading namespace qualifiers in a string. These qualifiers are
4118 * namespace names separated by "::"s. For example, for "::foo::p" this
4119 * command returns "::foo", and for "::" it returns "". This command is
4120 * the complement of the "namespace tail" command. Note that this command
4121 * does not check whether the "namespace" names are, in fact, the names
4122 * of currently defined namespaces. Handles the following syntax:
4123 *
4124 * namespace qualifiers string
4125 *
4126 * Results:
4127 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4128 *
4129 * Side effects:
4130 * Returns a result in the interpreter's result object. If anything goes
4131 * wrong, the result is an error message.
4132 *
4133 *----------------------------------------------------------------------
4134 */
4135
4136 static int
NamespaceQualifiersCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4137 NamespaceQualifiersCmd(
4138 ClientData dummy, /* Not used. */
4139 Tcl_Interp *interp, /* Current interpreter. */
4140 int objc, /* Number of arguments. */
4141 Tcl_Obj *const objv[]) /* Argument objects. */
4142 {
4143 register char *name, *p;
4144 int length;
4145
4146 if (objc != 3) {
4147 Tcl_WrongNumArgs(interp, 2, objv, "string");
4148 return TCL_ERROR;
4149 }
4150
4151 /*
4152 * Find the end of the string, then work backward and find the start of
4153 * the last "::" qualifier.
4154 */
4155
4156 name = TclGetString(objv[2]);
4157 for (p = name; *p != '\0'; p++) {
4158 /* empty body */
4159 }
4160 while (--p >= name) {
4161 if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
4162 p -= 2; /* Back up over the :: */
4163 while ((p >= name) && (*p == ':')) {
4164 p--; /* Back up over the preceeding : */
4165 }
4166 break;
4167 }
4168 }
4169
4170 if (p >= name) {
4171 length = p-name+1;
4172 Tcl_SetObjResult(interp, Tcl_NewStringObj(name, length));
4173 }
4174 return TCL_OK;
4175 }
4176
4177 /*
4178 *----------------------------------------------------------------------
4179 *
4180 * NamespaceUnknownCmd --
4181 *
4182 * Invoked to implement the "namespace unknown" command (TIP 181) that
4183 * sets or queries a per-namespace unknown command handler. This handler
4184 * is called when command lookup fails (current and global ns). The
4185 * default handler for the global namespace is ::unknown. The default
4186 * handler for other namespaces is to call the global namespace unknown
4187 * handler. Passing an empty list results in resetting the handler to its
4188 * default.
4189 *
4190 * namespace unknown ?handler?
4191 *
4192 * Results:
4193 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4194 *
4195 * Side effects:
4196 * If no handler is specified, returns a result in the interpreter's
4197 * result object, otherwise it sets the unknown handler pointer in the
4198 * current namespace to the script fragment provided. If anything goes
4199 * wrong, the result is an error message.
4200 *
4201 *----------------------------------------------------------------------
4202 */
4203
4204 static int
NamespaceUnknownCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4205 NamespaceUnknownCmd(
4206 ClientData dummy, /* Not used. */
4207 Tcl_Interp *interp, /* Current interpreter. */
4208 int objc, /* Number of arguments. */
4209 Tcl_Obj *const objv[]) /* Argument objects. */
4210 {
4211 Tcl_Namespace *currNsPtr;
4212 Tcl_Obj *resultPtr;
4213 int rc;
4214
4215 if (objc > 3) {
4216 Tcl_WrongNumArgs(interp, 2, objv, "?script?");
4217 return TCL_ERROR;
4218 }
4219
4220 currNsPtr = TclGetCurrentNamespace(interp);
4221
4222 if (objc == 2) {
4223 /*
4224 * Introspection - return the current namespace handler.
4225 */
4226
4227 resultPtr = Tcl_GetNamespaceUnknownHandler(interp, currNsPtr);
4228 if (resultPtr == NULL) {
4229 TclNewObj(resultPtr);
4230 }
4231 Tcl_SetObjResult(interp, resultPtr);
4232 } else {
4233 rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]);
4234 if (rc == TCL_OK) {
4235 Tcl_SetObjResult(interp, objv[2]);
4236 }
4237 return rc;
4238 }
4239 return TCL_OK;
4240 }
4241
4242 /*
4243 *----------------------------------------------------------------------
4244 *
4245 * Tcl_GetNamespaceUnknownHandler --
4246 *
4247 * Returns the unknown command handler registered for the given
4248 * namespace.
4249 *
4250 * Results:
4251 * Returns the current unknown command handler, or NULL if none exists
4252 * for the namespace.
4253 *
4254 * Side effects:
4255 * None.
4256 *
4257 *----------------------------------------------------------------------
4258 */
4259
4260 Tcl_Obj *
Tcl_GetNamespaceUnknownHandler(Tcl_Interp * interp,Tcl_Namespace * nsPtr)4261 Tcl_GetNamespaceUnknownHandler(
4262 Tcl_Interp *interp, /* The interpreter in which the namespace
4263 * exists. */
4264 Tcl_Namespace *nsPtr) /* The namespace. */
4265 {
4266 Namespace *currNsPtr = (Namespace *)nsPtr;
4267
4268 if (currNsPtr->unknownHandlerPtr == NULL &&
4269 currNsPtr == ((Interp *)interp)->globalNsPtr) {
4270 /*
4271 * Default handler for global namespace is "::unknown". For all other
4272 * namespaces, it is NULL (which falls back on the global unknown
4273 * handler).
4274 */
4275
4276 TclNewLiteralStringObj(currNsPtr->unknownHandlerPtr, "::unknown");
4277 Tcl_IncrRefCount(currNsPtr->unknownHandlerPtr);
4278 }
4279 return currNsPtr->unknownHandlerPtr;
4280 }
4281
4282 /*
4283 *----------------------------------------------------------------------
4284 *
4285 * Tcl_SetNamespaceUnknownHandler --
4286 *
4287 * Sets the unknown command handler for the given namespace to the
4288 * command prefix passed.
4289 *
4290 * Results:
4291 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4292 *
4293 * Side effects:
4294 * Sets the namespace unknown command handler. If the passed in handler
4295 * is NULL or an empty list, then the handler is reset to its default. If
4296 * an error occurs, then an error message is left in the interpreter
4297 * result.
4298 *
4299 *----------------------------------------------------------------------
4300 */
4301
4302 int
Tcl_SetNamespaceUnknownHandler(Tcl_Interp * interp,Tcl_Namespace * nsPtr,Tcl_Obj * handlerPtr)4303 Tcl_SetNamespaceUnknownHandler(
4304 Tcl_Interp *interp, /* Interpreter in which the namespace
4305 * exists. */
4306 Tcl_Namespace *nsPtr, /* Namespace which is being updated. */
4307 Tcl_Obj *handlerPtr) /* The new handler, or NULL to reset. */
4308 {
4309 int lstlen = 0;
4310 Namespace *currNsPtr = (Namespace *)nsPtr;
4311
4312 /*
4313 * Ensure that we check for errors *first* before we change anything.
4314 */
4315
4316 if (handlerPtr != NULL) {
4317 if (TclListObjLength(interp, handlerPtr, &lstlen) != TCL_OK) {
4318 /*
4319 * Not a list.
4320 */
4321
4322 return TCL_ERROR;
4323 }
4324 if (lstlen > 0) {
4325 /*
4326 * We are going to be saving this handler. Increment the reference
4327 * count before decrementing the refcount on the previous handler,
4328 * so that nothing strange can happen if we are told to set the
4329 * handler to the previous value.
4330 */
4331
4332 Tcl_IncrRefCount(handlerPtr);
4333 }
4334 }
4335
4336 /*
4337 * Remove old handler next.
4338 */
4339
4340 if (currNsPtr->unknownHandlerPtr != NULL) {
4341 Tcl_DecrRefCount(currNsPtr->unknownHandlerPtr);
4342 }
4343
4344 /*
4345 * Install the new handler.
4346 */
4347
4348 if (lstlen > 0) {
4349 /*
4350 * Just store the handler. It already has the correct reference count.
4351 */
4352
4353 currNsPtr->unknownHandlerPtr = handlerPtr;
4354 } else {
4355 /*
4356 * If NULL or an empty list is passed, this resets to the default
4357 * handler.
4358 */
4359
4360 currNsPtr->unknownHandlerPtr = NULL;
4361 }
4362 return TCL_OK;
4363 }
4364
4365 /*
4366 *----------------------------------------------------------------------
4367 *
4368 * NamespaceTailCmd --
4369 *
4370 * Invoked to implement the "namespace tail" command that returns the
4371 * trailing name at the end of a string with "::" namespace qualifiers.
4372 * These qualifiers are namespace names separated by "::"s. For example,
4373 * for "::foo::p" this command returns "p", and for "::" it returns "".
4374 * This command is the complement of the "namespace qualifiers" command.
4375 * Note that this command does not check whether the "namespace" names
4376 * are, in fact, the names of currently defined namespaces. Handles the
4377 * following syntax:
4378 *
4379 * namespace tail string
4380 *
4381 * Results:
4382 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4383 *
4384 * Side effects:
4385 * Returns a result in the interpreter's result object. If anything goes
4386 * wrong, the result is an error message.
4387 *
4388 *----------------------------------------------------------------------
4389 */
4390
4391 static int
NamespaceTailCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4392 NamespaceTailCmd(
4393 ClientData dummy, /* Not used. */
4394 Tcl_Interp *interp, /* Current interpreter. */
4395 int objc, /* Number of arguments. */
4396 Tcl_Obj *const objv[]) /* Argument objects. */
4397 {
4398 register char *name, *p;
4399
4400 if (objc != 3) {
4401 Tcl_WrongNumArgs(interp, 2, objv, "string");
4402 return TCL_ERROR;
4403 }
4404
4405 /*
4406 * Find the end of the string, then work backward and find the last "::"
4407 * qualifier.
4408 */
4409
4410 name = TclGetString(objv[2]);
4411 for (p = name; *p != '\0'; p++) {
4412 /* empty body */
4413 }
4414 while (--p > name) {
4415 if ((*p == ':') && (*(p-1) == ':')) {
4416 p++; /* Just after the last "::" */
4417 break;
4418 }
4419 }
4420
4421 if (p >= name) {
4422 Tcl_SetObjResult(interp, Tcl_NewStringObj(p, -1));
4423 }
4424 return TCL_OK;
4425 }
4426
4427 /*
4428 *----------------------------------------------------------------------
4429 *
4430 * NamespaceUpvarCmd --
4431 *
4432 * Invoked to implement the "namespace upvar" command, that creates
4433 * variables in the current scope linked to variables in another
4434 * namespace. Handles the following syntax:
4435 *
4436 * namespace upvar ns otherVar myVar ?otherVar myVar ...?
4437 *
4438 * Results:
4439 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4440 *
4441 * Side effects:
4442 * Creates new variables in the current scope, linked to the
4443 * corresponding variables in the stipulated nmamespace. If anything goes
4444 * wrong, the result is an error message.
4445 *
4446 *----------------------------------------------------------------------
4447 */
4448
4449 static int
NamespaceUpvarCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4450 NamespaceUpvarCmd(
4451 ClientData dummy, /* Not used. */
4452 Tcl_Interp *interp, /* Current interpreter. */
4453 int objc, /* Number of arguments. */
4454 Tcl_Obj *const objv[]) /* Argument objects. */
4455 {
4456 Interp *iPtr = (Interp *) interp;
4457 Tcl_Namespace *nsPtr, *savedNsPtr;
4458 Var *otherPtr, *arrayPtr;
4459 char *myName;
4460
4461 if (objc < 5 || !(objc & 1)) {
4462 Tcl_WrongNumArgs(interp, 2, objv,
4463 "ns otherVar myVar ?otherVar myVar ...?");
4464 return TCL_ERROR;
4465 }
4466
4467 if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
4468 return TCL_ERROR;
4469 }
4470
4471 objc -= 3;
4472 objv += 3;
4473
4474 for (; objc>0 ; objc-=2, objv+=2) {
4475 /*
4476 * Locate the other variable
4477 */
4478
4479 savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
4480 iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
4481 otherPtr = TclObjLookupVarEx(interp, objv[0], NULL,
4482 (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
4483 /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
4484 iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
4485 if (otherPtr == NULL) {
4486 return TCL_ERROR;
4487 }
4488
4489 /*
4490 * Create the new variable and link it to otherPtr.
4491 */
4492
4493 myName = TclGetString(objv[1]);
4494 if (TclPtrMakeUpvar(interp, otherPtr, myName, 0, -1) != TCL_OK) {
4495 return TCL_ERROR;
4496 }
4497 }
4498
4499 return TCL_OK;
4500 }
4501
4502 /*
4503 *----------------------------------------------------------------------
4504 *
4505 * NamespaceWhichCmd --
4506 *
4507 * Invoked to implement the "namespace which" command that returns the
4508 * fully-qualified name of a command or variable. If the specified
4509 * command or variable does not exist, it returns "". Handles the
4510 * following syntax:
4511 *
4512 * namespace which ?-command? ?-variable? name
4513 *
4514 * Results:
4515 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4516 *
4517 * Side effects:
4518 * Returns a result in the interpreter's result object. If anything goes
4519 * wrong, the result is an error message.
4520 *
4521 *----------------------------------------------------------------------
4522 */
4523
4524 static int
NamespaceWhichCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4525 NamespaceWhichCmd(
4526 ClientData dummy, /* Not used. */
4527 Tcl_Interp *interp, /* Current interpreter. */
4528 int objc, /* Number of arguments. */
4529 Tcl_Obj *const objv[]) /* Argument objects. */
4530 {
4531 static const char *opts[] = {
4532 "-command", "-variable", NULL
4533 };
4534 int lookupType = 0;
4535 Tcl_Obj *resultPtr;
4536
4537 if (objc < 3 || objc > 4) {
4538 badArgs:
4539 Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name");
4540 return TCL_ERROR;
4541 } else if (objc == 4) {
4542 /*
4543 * Look for a flag controlling the lookup.
4544 */
4545
4546 if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
4547 &lookupType) != TCL_OK) {
4548 /*
4549 * Preserve old style of error message!
4550 */
4551
4552 Tcl_ResetResult(interp);
4553 goto badArgs;
4554 }
4555 }
4556
4557 TclNewObj(resultPtr);
4558 switch (lookupType) {
4559 case 0: { /* -command */
4560 Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]);
4561
4562 if (cmd != NULL) {
4563 Tcl_GetCommandFullName(interp, cmd, resultPtr);
4564 }
4565 break;
4566 }
4567 case 1: { /* -variable */
4568 Tcl_Var var = Tcl_FindNamespaceVar(interp,
4569 TclGetString(objv[objc-1]), NULL, /*flags*/ 0);
4570
4571 if (var != NULL) {
4572 Tcl_GetVariableFullName(interp, var, resultPtr);
4573 }
4574 break;
4575 }
4576 }
4577 Tcl_SetObjResult(interp, resultPtr);
4578 return TCL_OK;
4579 }
4580
4581 /*
4582 *----------------------------------------------------------------------
4583 *
4584 * FreeNsNameInternalRep --
4585 *
4586 * Frees the resources associated with a nsName object's internal
4587 * representation.
4588 *
4589 * Results:
4590 * None.
4591 *
4592 * Side effects:
4593 * Decrements the ref count of any Namespace structure pointed to by the
4594 * nsName's internal representation. If there are no more references to
4595 * the namespace, it's structure will be freed.
4596 *
4597 *----------------------------------------------------------------------
4598 */
4599
4600 static void
FreeNsNameInternalRep(register Tcl_Obj * objPtr)4601 FreeNsNameInternalRep(
4602 register Tcl_Obj *objPtr) /* nsName object with internal representation
4603 * to free. */
4604 {
4605 register ResolvedNsName *resNamePtr = (ResolvedNsName *)
4606 objPtr->internalRep.twoPtrValue.ptr1;
4607 Namespace *nsPtr;
4608
4609 /*
4610 * Decrement the reference count of the namespace. If there are no more
4611 * references, free it up.
4612 */
4613
4614 resNamePtr->refCount--;
4615 if (resNamePtr->refCount == 0) {
4616
4617 /*
4618 * Decrement the reference count for the cached namespace. If the
4619 * namespace is dead, and there are no more references to it, free
4620 * it.
4621 */
4622
4623 nsPtr = resNamePtr->nsPtr;
4624 nsPtr->refCount--;
4625 if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
4626 NamespaceFree(nsPtr);
4627 }
4628 ckfree((char *) resNamePtr);
4629 }
4630 objPtr->typePtr = NULL;
4631 }
4632
4633 /*
4634 *----------------------------------------------------------------------
4635 *
4636 * DupNsNameInternalRep --
4637 *
4638 * Initializes the internal representation of a nsName object to a copy
4639 * of the internal representation of another nsName object.
4640 *
4641 * Results:
4642 * None.
4643 *
4644 * Side effects:
4645 * copyPtr's internal rep is set to refer to the same namespace
4646 * referenced by srcPtr's internal rep. Increments the ref count of the
4647 * ResolvedNsName structure used to hold the namespace reference.
4648 *
4649 *----------------------------------------------------------------------
4650 */
4651
4652 static void
DupNsNameInternalRep(Tcl_Obj * srcPtr,register Tcl_Obj * copyPtr)4653 DupNsNameInternalRep(
4654 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
4655 register Tcl_Obj *copyPtr) /* Object with internal rep to set. */
4656 {
4657 register ResolvedNsName *resNamePtr = (ResolvedNsName *)
4658 srcPtr->internalRep.twoPtrValue.ptr1;
4659
4660 copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
4661 resNamePtr->refCount++;
4662 copyPtr->typePtr = &nsNameType;
4663 }
4664
4665 /*
4666 *----------------------------------------------------------------------
4667 *
4668 * SetNsNameFromAny --
4669 *
4670 * Attempt to generate a nsName internal representation for a Tcl object.
4671 *
4672 * Results:
4673 * Returns TCL_OK if the value could be converted to a proper namespace
4674 * reference. Otherwise, it returns TCL_ERROR, along with an error
4675 * message in the interpreter's result object.
4676 *
4677 * Side effects:
4678 * If successful, the object is made a nsName object. Its internal rep is
4679 * set to point to a ResolvedNsName, which contains a cached pointer to
4680 * the Namespace. Reference counts are kept on both the ResolvedNsName
4681 * and the Namespace, so we can keep track of their usage and free them
4682 * when appropriate.
4683 *
4684 *----------------------------------------------------------------------
4685 */
4686
4687 static int
SetNsNameFromAny(Tcl_Interp * interp,register Tcl_Obj * objPtr)4688 SetNsNameFromAny(
4689 Tcl_Interp *interp, /* Points to the namespace in which to resolve
4690 * name. Also used for error reporting if not
4691 * NULL. */
4692 register Tcl_Obj *objPtr) /* The object to convert. */
4693 {
4694 const char *dummy;
4695 Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr;
4696 register ResolvedNsName *resNamePtr;
4697 const char *name;
4698
4699 if (interp == NULL) {
4700 return TCL_ERROR;
4701 }
4702
4703 name = TclGetString(objPtr);
4704 TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS,
4705 &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy);
4706
4707 /*
4708 * If we found a namespace, then create a new ResolvedNsName structure
4709 * that holds a reference to it.
4710 */
4711
4712 if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) {
4713 /*
4714 * Our failed lookup proves any previously cached nsName intrep is no
4715 * longer valid. Get rid of it so we no longer waste memory storing
4716 * it, nor time determining its invalidity again and again.
4717 */
4718
4719 if (objPtr->typePtr == &nsNameType) {
4720 TclFreeIntRep(objPtr);
4721 objPtr->typePtr = NULL;
4722 }
4723 return TCL_ERROR;
4724 }
4725
4726 nsPtr->refCount++;
4727 resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
4728 resNamePtr->nsPtr = nsPtr;
4729 if ((name[0] == ':') && (name[1] == ':')) {
4730 resNamePtr->refNsPtr = NULL;
4731 } else {
4732 resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
4733 }
4734 resNamePtr->refCount = 1;
4735 TclFreeIntRep(objPtr);
4736 objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr;
4737 objPtr->typePtr = &nsNameType;
4738 return TCL_OK;
4739 }
4740
4741 /*
4742 *----------------------------------------------------------------------
4743 *
4744 * NamespaceEnsembleCmd --
4745 *
4746 * Invoked to implement the "namespace ensemble" command that creates and
4747 * manipulates ensembles built on top of namespaces. Handles the
4748 * following syntax:
4749 *
4750 * namespace ensemble name ?dictionary?
4751 *
4752 * Results:
4753 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
4754 *
4755 * Side effects:
4756 * Creates the ensemble for the namespace if one did not previously
4757 * exist. Alternatively, alters the way that the ensemble's subcommand =>
4758 * implementation prefix is configured.
4759 *
4760 *----------------------------------------------------------------------
4761 */
4762
4763 static int
NamespaceEnsembleCmd(ClientData dummy,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])4764 NamespaceEnsembleCmd(
4765 ClientData dummy,
4766 Tcl_Interp *interp,
4767 int objc,
4768 Tcl_Obj *const objv[])
4769 {
4770 Namespace *nsPtr;
4771 Tcl_Command token;
4772 static const char *subcommands[] = {
4773 "configure", "create", "exists", NULL
4774 };
4775 enum EnsSubcmds {
4776 ENS_CONFIG, ENS_CREATE, ENS_EXISTS
4777 };
4778 static const char *createOptions[] = {
4779 "-command", "-map", "-prefixes", "-subcommands", "-unknown", NULL
4780 };
4781 enum EnsCreateOpts {
4782 CRT_CMD, CRT_MAP, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
4783 };
4784 static const char *configOptions[] = {
4785 "-map", "-namespace", "-prefixes", "-subcommands", "-unknown", NULL
4786 };
4787 enum EnsConfigOpts {
4788 CONF_MAP, CONF_NAMESPACE, CONF_PREFIX, CONF_SUBCMDS, CONF_UNKNOWN
4789 };
4790 int index;
4791
4792 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
4793 if (nsPtr == NULL || nsPtr->flags & NS_DYING) {
4794 if (!Tcl_InterpDeleted(interp)) {
4795 Tcl_AppendResult(interp,
4796 "tried to manipulate ensemble of deleted namespace", NULL);
4797 }
4798 return TCL_ERROR;
4799 }
4800
4801 if (objc < 3) {
4802 Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
4803 return TCL_ERROR;
4804 }
4805 if (Tcl_GetIndexFromObj(interp, objv[2], subcommands, "subcommand", 0,
4806 &index) != TCL_OK) {
4807 return TCL_ERROR;
4808 }
4809
4810 switch ((enum EnsSubcmds) index) {
4811 case ENS_CREATE: {
4812 char *name;
4813 Tcl_DictSearch search;
4814 Tcl_Obj *listObj;
4815 int done, len, allocatedMapFlag = 0;
4816 /*
4817 * Defaults
4818 */
4819 Tcl_Obj *subcmdObj = NULL;
4820 Tcl_Obj *mapObj = NULL;
4821 int permitPrefix = 1;
4822 Tcl_Obj *unknownObj = NULL;
4823
4824 objv += 3;
4825 objc -= 3;
4826
4827 /*
4828 * Work out what name to use for the command to create. If supplied,
4829 * it is either fully specified or relative to the current namespace.
4830 * If not supplied, it is exactly the name of the current namespace.
4831 */
4832
4833 name = nsPtr->fullName;
4834
4835 /*
4836 * Parse the option list, applying type checks as we go. Note that we
4837 * are not incrementing any reference counts in the objects at this
4838 * stage, so the presence of an option multiple times won't cause any
4839 * memory leaks.
4840 */
4841
4842 for (; objc>1 ; objc-=2,objv+=2 ) {
4843 if (Tcl_GetIndexFromObj(interp, objv[0], createOptions, "option",
4844 0, &index) != TCL_OK) {
4845 if (allocatedMapFlag) {
4846 Tcl_DecrRefCount(mapObj);
4847 }
4848 return TCL_ERROR;
4849 }
4850 switch ((enum EnsCreateOpts) index) {
4851 case CRT_CMD:
4852 name = TclGetString(objv[1]);
4853 continue;
4854 case CRT_SUBCMDS:
4855 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
4856 if (allocatedMapFlag) {
4857 Tcl_DecrRefCount(mapObj);
4858 }
4859 return TCL_ERROR;
4860 }
4861 subcmdObj = (len > 0 ? objv[1] : NULL);
4862 continue;
4863 case CRT_MAP: {
4864 Tcl_Obj *patchedDict = NULL, *subcmdObj;
4865
4866 /*
4867 * Verify that the map is sensible.
4868 */
4869
4870 if (Tcl_DictObjFirst(interp, objv[1], &search,
4871 &subcmdObj, &listObj, &done) != TCL_OK) {
4872 if (allocatedMapFlag) {
4873 Tcl_DecrRefCount(mapObj);
4874 }
4875 return TCL_ERROR;
4876 }
4877 if (done) {
4878 mapObj = NULL;
4879 continue;
4880 }
4881 do {
4882 Tcl_Obj **listv;
4883 char *cmd;
4884
4885 if (TclListObjGetElements(interp, listObj, &len,
4886 &listv) != TCL_OK) {
4887 Tcl_DictObjDone(&search);
4888 if (patchedDict) {
4889 Tcl_DecrRefCount(patchedDict);
4890 }
4891 if (allocatedMapFlag) {
4892 Tcl_DecrRefCount(mapObj);
4893 }
4894 return TCL_ERROR;
4895 }
4896 if (len < 1) {
4897 Tcl_SetResult(interp,
4898 "ensemble subcommand implementations "
4899 "must be non-empty lists", TCL_STATIC);
4900 Tcl_DictObjDone(&search);
4901 if (patchedDict) {
4902 Tcl_DecrRefCount(patchedDict);
4903 }
4904 if (allocatedMapFlag) {
4905 Tcl_DecrRefCount(mapObj);
4906 }
4907 return TCL_ERROR;
4908 }
4909 cmd = TclGetString(listv[0]);
4910 if (!(cmd[0] == ':' && cmd[1] == ':')) {
4911 Tcl_Obj *newList = Tcl_NewListObj(len, listv);
4912 Tcl_Obj *newCmd = Tcl_NewStringObj(nsPtr->fullName,-1);
4913
4914 if (nsPtr->parentPtr) {
4915 Tcl_AppendStringsToObj(newCmd, "::", NULL);
4916 }
4917 Tcl_AppendObjToObj(newCmd, listv[0]);
4918 Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
4919 if (patchedDict == NULL) {
4920 patchedDict = Tcl_DuplicateObj(objv[1]);
4921 }
4922 Tcl_DictObjPut(NULL, patchedDict, subcmdObj, newList);
4923 }
4924 Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
4925 } while (!done);
4926
4927 if (allocatedMapFlag) {
4928 Tcl_DecrRefCount(mapObj);
4929 }
4930 mapObj = (patchedDict ? patchedDict : objv[1]);
4931 if (patchedDict) {
4932 allocatedMapFlag = 1;
4933 }
4934 continue;
4935 }
4936 case CRT_PREFIX:
4937 if (Tcl_GetBooleanFromObj(interp, objv[1],
4938 &permitPrefix) != TCL_OK) {
4939 if (allocatedMapFlag) {
4940 Tcl_DecrRefCount(mapObj);
4941 }
4942 return TCL_ERROR;
4943 }
4944 continue;
4945 case CRT_UNKNOWN:
4946 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
4947 if (allocatedMapFlag) {
4948 Tcl_DecrRefCount(mapObj);
4949 }
4950 return TCL_ERROR;
4951 }
4952 unknownObj = (len > 0 ? objv[1] : NULL);
4953 continue;
4954 }
4955 }
4956
4957 /*
4958 * Create the ensemble. Note that this might delete another ensemble
4959 * linked to the same namespace, so we must be careful. However, we
4960 * should be OK because we only link the namespace into the list once
4961 * we've created it (and after any deletions have occurred.)
4962 */
4963
4964 token = Tcl_CreateEnsemble(interp, name, NULL,
4965 (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
4966 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
4967 Tcl_SetEnsembleMappingDict(interp, token, mapObj);
4968 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
4969
4970 /*
4971 * Tricky! Must ensure that the result is not shared (command delete
4972 * traces could have corrupted the pristine object that we started
4973 * with). [Snit test rename-1.5]
4974 */
4975
4976 Tcl_ResetResult(interp);
4977 Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
4978 return TCL_OK;
4979 }
4980
4981 case ENS_EXISTS:
4982 if (objc != 4) {
4983 Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
4984 return TCL_ERROR;
4985 }
4986 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
4987 Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
4988 return TCL_OK;
4989
4990 case ENS_CONFIG:
4991 if (objc < 4 || (objc != 5 && objc & 1)) {
4992 Tcl_WrongNumArgs(interp, 3, objv, "cmdname ?opt? ?value? ...");
4993 return TCL_ERROR;
4994 }
4995 token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
4996 if (token == NULL) {
4997 return TCL_ERROR;
4998 }
4999
5000 if (objc == 5) {
5001 Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
5002
5003 if (Tcl_GetIndexFromObj(interp, objv[4], configOptions, "option",
5004 0, &index) != TCL_OK) {
5005 return TCL_ERROR;
5006 }
5007 switch ((enum EnsConfigOpts) index) {
5008 case CONF_SUBCMDS:
5009 Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
5010 if (resultObj != NULL) {
5011 Tcl_SetObjResult(interp, resultObj);
5012 }
5013 break;
5014 case CONF_MAP:
5015 Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
5016 if (resultObj != NULL) {
5017 Tcl_SetObjResult(interp, resultObj);
5018 }
5019 break;
5020 case CONF_NAMESPACE: {
5021 Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
5022
5023 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
5024 Tcl_SetResult(interp, ((Namespace *)namespacePtr)->fullName,
5025 TCL_VOLATILE);
5026 break;
5027 }
5028 case CONF_PREFIX: {
5029 int flags = 0; /* silence gcc 4 warning */
5030
5031 Tcl_GetEnsembleFlags(NULL, token, &flags);
5032 Tcl_SetObjResult(interp,
5033 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
5034 break;
5035 }
5036 case CONF_UNKNOWN:
5037 Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
5038 if (resultObj != NULL) {
5039 Tcl_SetObjResult(interp, resultObj);
5040 }
5041 break;
5042 }
5043 return TCL_OK;
5044
5045 } else if (objc == 4) {
5046 /*
5047 * Produce list of all information.
5048 */
5049
5050 Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
5051 Tcl_Namespace *namespacePtr = NULL; /* silence gcc 4 warning */
5052 int flags = 0; /* silence gcc 4 warning */
5053
5054 TclNewObj(resultObj);
5055
5056 /* -map option */
5057 Tcl_ListObjAppendElement(NULL, resultObj,
5058 Tcl_NewStringObj(configOptions[CONF_MAP], -1));
5059 Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
5060 Tcl_ListObjAppendElement(NULL, resultObj,
5061 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
5062
5063 /* -namespace option */
5064 Tcl_ListObjAppendElement(NULL, resultObj,
5065 Tcl_NewStringObj(configOptions[CONF_NAMESPACE], -1));
5066 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
5067 Tcl_ListObjAppendElement(NULL, resultObj,
5068 Tcl_NewStringObj(((Namespace *)namespacePtr)->fullName,
5069 -1));
5070
5071 /* -prefix option */
5072 Tcl_ListObjAppendElement(NULL, resultObj,
5073 Tcl_NewStringObj(configOptions[CONF_PREFIX], -1));
5074 Tcl_GetEnsembleFlags(NULL, token, &flags);
5075 Tcl_ListObjAppendElement(NULL, resultObj,
5076 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
5077
5078 /* -subcommands option */
5079 Tcl_ListObjAppendElement(NULL, resultObj,
5080 Tcl_NewStringObj(configOptions[CONF_SUBCMDS], -1));
5081 Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
5082 Tcl_ListObjAppendElement(NULL, resultObj,
5083 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
5084
5085 /* -unknown option */
5086 Tcl_ListObjAppendElement(NULL, resultObj,
5087 Tcl_NewStringObj(configOptions[CONF_UNKNOWN], -1));
5088 Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
5089 Tcl_ListObjAppendElement(NULL, resultObj,
5090 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
5091
5092 Tcl_SetObjResult(interp, resultObj);
5093 return TCL_OK;
5094 } else {
5095 Tcl_DictSearch search;
5096 Tcl_Obj *listObj;
5097 int done, len, allocatedMapFlag = 0;
5098 Tcl_Obj *subcmdObj = NULL, *mapObj = NULL,
5099 *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
5100 int permitPrefix, flags = 0; /* silence gcc 4 warning */
5101
5102 Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
5103 Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
5104 Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
5105 Tcl_GetEnsembleFlags(NULL, token, &flags);
5106 permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
5107
5108 objv += 4;
5109 objc -= 4;
5110
5111 /*
5112 * Parse the option list, applying type checks as we go. Note that
5113 * we are not incrementing any reference counts in the objects at
5114 * this stage, so the presence of an option multiple times won't
5115 * cause any memory leaks.
5116 */
5117
5118 for (; objc>0 ; objc-=2,objv+=2 ) {
5119 if (Tcl_GetIndexFromObj(interp, objv[0], configOptions,
5120 "option", 0, &index) != TCL_OK) {
5121 if (allocatedMapFlag) {
5122 Tcl_DecrRefCount(mapObj);
5123 }
5124 return TCL_ERROR;
5125 }
5126 switch ((enum EnsConfigOpts) index) {
5127 case CONF_SUBCMDS:
5128 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
5129 if (allocatedMapFlag) {
5130 Tcl_DecrRefCount(mapObj);
5131 }
5132 return TCL_ERROR;
5133 }
5134 subcmdObj = (len > 0 ? objv[1] : NULL);
5135 continue;
5136 case CONF_MAP: {
5137 Tcl_Obj *patchedDict = NULL, *subcmdObj;
5138
5139 /*
5140 * Verify that the map is sensible.
5141 */
5142
5143 if (Tcl_DictObjFirst(interp, objv[1], &search,
5144 &subcmdObj, &listObj, &done) != TCL_OK) {
5145 if (allocatedMapFlag) {
5146 Tcl_DecrRefCount(mapObj);
5147 }
5148 return TCL_ERROR;
5149 }
5150 if (done) {
5151 mapObj = NULL;
5152 continue;
5153 }
5154 do {
5155 Tcl_Obj **listv;
5156 char *cmd;
5157
5158 if (TclListObjGetElements(interp, listObj, &len,
5159 &listv) != TCL_OK) {
5160 Tcl_DictObjDone(&search);
5161 if (patchedDict) {
5162 Tcl_DecrRefCount(patchedDict);
5163 }
5164 if (allocatedMapFlag) {
5165 Tcl_DecrRefCount(mapObj);
5166 }
5167 return TCL_ERROR;
5168 }
5169 if (len < 1) {
5170 Tcl_SetResult(interp,
5171 "ensemble subcommand implementations "
5172 "must be non-empty lists", TCL_STATIC);
5173 Tcl_DictObjDone(&search);
5174 if (patchedDict) {
5175 Tcl_DecrRefCount(patchedDict);
5176 }
5177 if (allocatedMapFlag) {
5178 Tcl_DecrRefCount(mapObj);
5179 }
5180 return TCL_ERROR;
5181 }
5182 cmd = TclGetString(listv[0]);
5183 if (!(cmd[0] == ':' && cmd[1] == ':')) {
5184 Tcl_Obj *newList = Tcl_NewListObj(len, listv);
5185 Tcl_Obj *newCmd =
5186 Tcl_NewStringObj(nsPtr->fullName, -1);
5187 if (nsPtr->parentPtr) {
5188 Tcl_AppendStringsToObj(newCmd, "::", NULL);
5189 }
5190 Tcl_AppendObjToObj(newCmd, listv[0]);
5191 Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd);
5192 if (patchedDict == NULL) {
5193 patchedDict = Tcl_DuplicateObj(objv[1]);
5194 }
5195 Tcl_DictObjPut(NULL, patchedDict, subcmdObj,
5196 newList);
5197 }
5198 Tcl_DictObjNext(&search, &subcmdObj, &listObj, &done);
5199 } while (!done);
5200 if (allocatedMapFlag) {
5201 Tcl_DecrRefCount(mapObj);
5202 }
5203 mapObj = (patchedDict ? patchedDict : objv[1]);
5204 if (patchedDict) {
5205 allocatedMapFlag = 1;
5206 }
5207 continue;
5208 }
5209 case CONF_NAMESPACE:
5210 if (allocatedMapFlag) {
5211 Tcl_DecrRefCount(mapObj);
5212 }
5213 Tcl_AppendResult(interp, "option -namespace is read-only",
5214 NULL);
5215 return TCL_ERROR;
5216 case CONF_PREFIX:
5217 if (Tcl_GetBooleanFromObj(interp, objv[1],
5218 &permitPrefix) != TCL_OK) {
5219 if (allocatedMapFlag) {
5220 Tcl_DecrRefCount(mapObj);
5221 }
5222 return TCL_ERROR;
5223 }
5224 continue;
5225 case CONF_UNKNOWN:
5226 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
5227 if (allocatedMapFlag) {
5228 Tcl_DecrRefCount(mapObj);
5229 }
5230 return TCL_ERROR;
5231 }
5232 unknownObj = (len > 0 ? objv[1] : NULL);
5233 continue;
5234 }
5235 }
5236
5237 /*
5238 * Update the namespace now that we've finished the parsing stage.
5239 */
5240
5241 flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
5242 : flags&~TCL_ENSEMBLE_PREFIX);
5243 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
5244 Tcl_SetEnsembleMappingDict(interp, token, mapObj);
5245 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
5246 Tcl_SetEnsembleFlags(interp, token, flags);
5247 return TCL_OK;
5248 }
5249
5250 default:
5251 Tcl_Panic("unexpected ensemble command");
5252 }
5253 return TCL_OK;
5254 }
5255
5256 /*
5257 *----------------------------------------------------------------------
5258 *
5259 * Tcl_CreateEnsemble --
5260 *
5261 * Create a simple ensemble attached to the given namespace.
5262 *
5263 * Results:
5264 * The token for the command created.
5265 *
5266 * Side effects:
5267 * The ensemble is created and marked for compilation.
5268 *
5269 *----------------------------------------------------------------------
5270 */
5271
5272 Tcl_Command
Tcl_CreateEnsemble(Tcl_Interp * interp,const char * name,Tcl_Namespace * namespacePtr,int flags)5273 Tcl_CreateEnsemble(
5274 Tcl_Interp *interp,
5275 const char *name,
5276 Tcl_Namespace *namespacePtr,
5277 int flags)
5278 {
5279 Namespace *nsPtr = (Namespace *) namespacePtr;
5280 EnsembleConfig *ensemblePtr = (EnsembleConfig *)
5281 ckalloc(sizeof(EnsembleConfig));
5282 Tcl_Obj *nameObj = NULL;
5283
5284 if (nsPtr == NULL) {
5285 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
5286 }
5287
5288 /*
5289 * Make the name of the ensemble into a fully qualified name. This might
5290 * allocate a temporary object.
5291 */
5292
5293 if (!(name[0] == ':' && name[1] == ':')) {
5294 nameObj = Tcl_NewStringObj(nsPtr->fullName, -1);
5295 if (nsPtr->parentPtr == NULL) {
5296 Tcl_AppendStringsToObj(nameObj, name, NULL);
5297 } else {
5298 Tcl_AppendStringsToObj(nameObj, "::", name, NULL);
5299 }
5300 Tcl_IncrRefCount(nameObj);
5301 name = TclGetString(nameObj);
5302 }
5303
5304 ensemblePtr->nsPtr = nsPtr;
5305 ensemblePtr->epoch = 0;
5306 Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
5307 ensemblePtr->subcommandArrayPtr = NULL;
5308 ensemblePtr->subcmdList = NULL;
5309 ensemblePtr->subcommandDict = NULL;
5310 ensemblePtr->flags = flags;
5311 ensemblePtr->unknownHandler = NULL;
5312 ensemblePtr->token = Tcl_CreateObjCommand(interp, name,
5313 NsEnsembleImplementationCmd, ensemblePtr, DeleteEnsembleConfig);
5314 ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
5315 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
5316
5317 /*
5318 * Trigger an eventual recomputation of the ensemble command set. Note
5319 * that this is slightly tricky, as it means that we are not actually
5320 * counting the number of namespace export actions, but it is the simplest
5321 * way to go!
5322 */
5323
5324 nsPtr->exportLookupEpoch++;
5325
5326 if (flags & ENSEMBLE_COMPILE) {
5327 ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
5328 }
5329
5330 if (nameObj != NULL) {
5331 TclDecrRefCount(nameObj);
5332 }
5333 return ensemblePtr->token;
5334 }
5335
5336 /*
5337 *----------------------------------------------------------------------
5338 *
5339 * Tcl_SetEnsembleSubcommandList --
5340 *
5341 * Set the subcommand list for a particular ensemble.
5342 *
5343 * Results:
5344 * Tcl result code (error if command token does not indicate an ensemble
5345 * or the subcommand list - if non-NULL - is not a list).
5346 *
5347 * Side effects:
5348 * The ensemble is updated and marked for recompilation.
5349 *
5350 *----------------------------------------------------------------------
5351 */
5352
5353 int
Tcl_SetEnsembleSubcommandList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * subcmdList)5354 Tcl_SetEnsembleSubcommandList(
5355 Tcl_Interp *interp,
5356 Tcl_Command token,
5357 Tcl_Obj *subcmdList)
5358 {
5359 Command *cmdPtr = (Command *) token;
5360 EnsembleConfig *ensemblePtr;
5361 Tcl_Obj *oldList;
5362
5363 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5364 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5365 return TCL_ERROR;
5366 }
5367 if (subcmdList != NULL) {
5368 int length;
5369
5370 if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
5371 return TCL_ERROR;
5372 }
5373 if (length < 1) {
5374 subcmdList = NULL;
5375 }
5376 }
5377
5378 ensemblePtr = cmdPtr->objClientData;
5379 oldList = ensemblePtr->subcmdList;
5380 ensemblePtr->subcmdList = subcmdList;
5381 if (subcmdList != NULL) {
5382 Tcl_IncrRefCount(subcmdList);
5383 }
5384 if (oldList != NULL) {
5385 TclDecrRefCount(oldList);
5386 }
5387
5388 /*
5389 * Trigger an eventual recomputation of the ensemble command set. Note
5390 * that this is slightly tricky, as it means that we are not actually
5391 * counting the number of namespace export actions, but it is the simplest
5392 * way to go!
5393 */
5394
5395 ensemblePtr->nsPtr->exportLookupEpoch++;
5396
5397 /*
5398 * Special hack to make compiling of [info exists] work when the
5399 * dictionary is modified.
5400 */
5401
5402 if (cmdPtr->compileProc != NULL) {
5403 ((Interp *)interp)->compileEpoch++;
5404 }
5405
5406 return TCL_OK;
5407 }
5408
5409 /*
5410 *----------------------------------------------------------------------
5411 *
5412 * Tcl_SetEnsembleMappingDict --
5413 *
5414 * Set the mapping dictionary for a particular ensemble.
5415 *
5416 * Results:
5417 * Tcl result code (error if command token does not indicate an ensemble
5418 * or the mapping - if non-NULL - is not a dict).
5419 *
5420 * Side effects:
5421 * The ensemble is updated and marked for recompilation.
5422 *
5423 *----------------------------------------------------------------------
5424 */
5425
5426 int
Tcl_SetEnsembleMappingDict(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * mapDict)5427 Tcl_SetEnsembleMappingDict(
5428 Tcl_Interp *interp,
5429 Tcl_Command token,
5430 Tcl_Obj *mapDict)
5431 {
5432 Command *cmdPtr = (Command *) token;
5433 EnsembleConfig *ensemblePtr;
5434 Tcl_Obj *oldDict;
5435
5436 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5437 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5438 return TCL_ERROR;
5439 }
5440 if (mapDict != NULL) {
5441 int size, done;
5442 Tcl_DictSearch search;
5443 Tcl_Obj *valuePtr;
5444
5445 if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
5446 return TCL_ERROR;
5447 }
5448
5449 for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
5450 !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
5451 Tcl_Obj *cmdPtr;
5452 const char *bytes;
5453
5454 if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdPtr) != TCL_OK) {
5455 Tcl_DictObjDone(&search);
5456 return TCL_ERROR;
5457 }
5458 bytes = TclGetString(cmdPtr);
5459 if (bytes[0] != ':' || bytes[1] != ':') {
5460 Tcl_AppendResult(interp,
5461 "ensemble target is not a fully-qualified command",
5462 NULL);
5463 Tcl_DictObjDone(&search);
5464 return TCL_ERROR;
5465 }
5466 }
5467
5468 if (size < 1) {
5469 mapDict = NULL;
5470 }
5471 }
5472
5473 ensemblePtr = cmdPtr->objClientData;
5474 oldDict = ensemblePtr->subcommandDict;
5475 ensemblePtr->subcommandDict = mapDict;
5476 if (mapDict != NULL) {
5477 Tcl_IncrRefCount(mapDict);
5478 }
5479 if (oldDict != NULL) {
5480 TclDecrRefCount(oldDict);
5481 }
5482
5483 /*
5484 * Trigger an eventual recomputation of the ensemble command set. Note
5485 * that this is slightly tricky, as it means that we are not actually
5486 * counting the number of namespace export actions, but it is the simplest
5487 * way to go!
5488 */
5489
5490 ensemblePtr->nsPtr->exportLookupEpoch++;
5491
5492 /*
5493 * Special hack to make compiling of [info exists] work when the
5494 * dictionary is modified.
5495 */
5496
5497 if (cmdPtr->compileProc != NULL) {
5498 ((Interp *)interp)->compileEpoch++;
5499 }
5500
5501 return TCL_OK;
5502 }
5503
5504 /*
5505 *----------------------------------------------------------------------
5506 *
5507 * Tcl_SetEnsembleUnknownHandler --
5508 *
5509 * Set the unknown handler for a particular ensemble.
5510 *
5511 * Results:
5512 * Tcl result code (error if command token does not indicate an ensemble
5513 * or the unknown handler - if non-NULL - is not a list).
5514 *
5515 * Side effects:
5516 * The ensemble is updated and marked for recompilation.
5517 *
5518 *----------------------------------------------------------------------
5519 */
5520
5521 int
Tcl_SetEnsembleUnknownHandler(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * unknownList)5522 Tcl_SetEnsembleUnknownHandler(
5523 Tcl_Interp *interp,
5524 Tcl_Command token,
5525 Tcl_Obj *unknownList)
5526 {
5527 Command *cmdPtr = (Command *) token;
5528 EnsembleConfig *ensemblePtr;
5529 Tcl_Obj *oldList;
5530
5531 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5532 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5533 return TCL_ERROR;
5534 }
5535 if (unknownList != NULL) {
5536 int length;
5537
5538 if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
5539 return TCL_ERROR;
5540 }
5541 if (length < 1) {
5542 unknownList = NULL;
5543 }
5544 }
5545
5546 ensemblePtr = cmdPtr->objClientData;
5547 oldList = ensemblePtr->unknownHandler;
5548 ensemblePtr->unknownHandler = unknownList;
5549 if (unknownList != NULL) {
5550 Tcl_IncrRefCount(unknownList);
5551 }
5552 if (oldList != NULL) {
5553 TclDecrRefCount(oldList);
5554 }
5555
5556 /*
5557 * Trigger an eventual recomputation of the ensemble command set. Note
5558 * that this is slightly tricky, as it means that we are not actually
5559 * counting the number of namespace export actions, but it is the simplest
5560 * way to go!
5561 */
5562
5563 ensemblePtr->nsPtr->exportLookupEpoch++;
5564
5565 return TCL_OK;
5566 }
5567
5568 /*
5569 *----------------------------------------------------------------------
5570 *
5571 * Tcl_SetEnsembleFlags --
5572 *
5573 * Set the flags for a particular ensemble.
5574 *
5575 * Results:
5576 * Tcl result code (error if command token does not indicate an
5577 * ensemble).
5578 *
5579 * Side effects:
5580 * The ensemble is updated and marked for recompilation.
5581 *
5582 *----------------------------------------------------------------------
5583 */
5584
5585 int
Tcl_SetEnsembleFlags(Tcl_Interp * interp,Tcl_Command token,int flags)5586 Tcl_SetEnsembleFlags(
5587 Tcl_Interp *interp,
5588 Tcl_Command token,
5589 int flags)
5590 {
5591 Command *cmdPtr = (Command *) token;
5592 EnsembleConfig *ensemblePtr;
5593 int wasCompiled;
5594
5595 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5596 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5597 return TCL_ERROR;
5598 }
5599
5600 ensemblePtr = cmdPtr->objClientData;
5601 wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
5602
5603 /*
5604 * This API refuses to set the ENS_DEAD flag...
5605 */
5606
5607 ensemblePtr->flags &= ENS_DEAD;
5608 ensemblePtr->flags |= flags & ~ENS_DEAD;
5609
5610 /*
5611 * Trigger an eventual recomputation of the ensemble command set. Note
5612 * that this is slightly tricky, as it means that we are not actually
5613 * counting the number of namespace export actions, but it is the simplest
5614 * way to go!
5615 */
5616
5617 ensemblePtr->nsPtr->exportLookupEpoch++;
5618
5619 /*
5620 * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
5621 * compiler function and bump the interpreter's compilation epoch so that
5622 * bytecode gets regenerated.
5623 */
5624
5625 if (flags & ENSEMBLE_COMPILE) {
5626 if (!wasCompiled) {
5627 ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
5628 ((Interp *) interp)->compileEpoch++;
5629 }
5630 } else {
5631 if (wasCompiled) {
5632 ((Command*) ensemblePtr->token)->compileProc = NULL;
5633 ((Interp *) interp)->compileEpoch++;
5634 }
5635 }
5636
5637 return TCL_OK;
5638 }
5639
5640 /*
5641 *----------------------------------------------------------------------
5642 *
5643 * Tcl_GetEnsembleSubcommandList --
5644 *
5645 * Get the list of subcommands associated with a particular ensemble.
5646 *
5647 * Results:
5648 * Tcl result code (error if command token does not indicate an
5649 * ensemble). The list of subcommands is returned by updating the
5650 * variable pointed to by the last parameter (NULL if this is to be
5651 * derived from the mapping dictionary or the associated namespace's
5652 * exported commands).
5653 *
5654 * Side effects:
5655 * None
5656 *
5657 *----------------------------------------------------------------------
5658 */
5659
5660 int
Tcl_GetEnsembleSubcommandList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** subcmdListPtr)5661 Tcl_GetEnsembleSubcommandList(
5662 Tcl_Interp *interp,
5663 Tcl_Command token,
5664 Tcl_Obj **subcmdListPtr)
5665 {
5666 Command *cmdPtr = (Command *) token;
5667 EnsembleConfig *ensemblePtr;
5668
5669 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5670 if (interp != NULL) {
5671 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5672 }
5673 return TCL_ERROR;
5674 }
5675
5676 ensemblePtr = cmdPtr->objClientData;
5677 *subcmdListPtr = ensemblePtr->subcmdList;
5678 return TCL_OK;
5679 }
5680
5681 /*
5682 *----------------------------------------------------------------------
5683 *
5684 * Tcl_GetEnsembleMappingDict --
5685 *
5686 * Get the command mapping dictionary associated with a particular
5687 * ensemble.
5688 *
5689 * Results:
5690 * Tcl result code (error if command token does not indicate an
5691 * ensemble). The mapping dict is returned by updating the variable
5692 * pointed to by the last parameter (NULL if none is installed).
5693 *
5694 * Side effects:
5695 * None
5696 *
5697 *----------------------------------------------------------------------
5698 */
5699
5700 int
Tcl_GetEnsembleMappingDict(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** mapDictPtr)5701 Tcl_GetEnsembleMappingDict(
5702 Tcl_Interp *interp,
5703 Tcl_Command token,
5704 Tcl_Obj **mapDictPtr)
5705 {
5706 Command *cmdPtr = (Command *) token;
5707 EnsembleConfig *ensemblePtr;
5708
5709 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5710 if (interp != NULL) {
5711 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5712 }
5713 return TCL_ERROR;
5714 }
5715
5716 ensemblePtr = cmdPtr->objClientData;
5717 *mapDictPtr = ensemblePtr->subcommandDict;
5718 return TCL_OK;
5719 }
5720
5721 /*
5722 *----------------------------------------------------------------------
5723 *
5724 * Tcl_GetEnsembleUnknownHandler --
5725 *
5726 * Get the unknown handler associated with a particular ensemble.
5727 *
5728 * Results:
5729 * Tcl result code (error if command token does not indicate an
5730 * ensemble). The unknown handler is returned by updating the variable
5731 * pointed to by the last parameter (NULL if no handler is installed).
5732 *
5733 * Side effects:
5734 * None
5735 *
5736 *----------------------------------------------------------------------
5737 */
5738
5739 int
Tcl_GetEnsembleUnknownHandler(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** unknownListPtr)5740 Tcl_GetEnsembleUnknownHandler(
5741 Tcl_Interp *interp,
5742 Tcl_Command token,
5743 Tcl_Obj **unknownListPtr)
5744 {
5745 Command *cmdPtr = (Command *) token;
5746 EnsembleConfig *ensemblePtr;
5747
5748 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5749 if (interp != NULL) {
5750 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5751 }
5752 return TCL_ERROR;
5753 }
5754
5755 ensemblePtr = cmdPtr->objClientData;
5756 *unknownListPtr = ensemblePtr->unknownHandler;
5757 return TCL_OK;
5758 }
5759
5760 /*
5761 *----------------------------------------------------------------------
5762 *
5763 * Tcl_GetEnsembleFlags --
5764 *
5765 * Get the flags for a particular ensemble.
5766 *
5767 * Results:
5768 * Tcl result code (error if command token does not indicate an
5769 * ensemble). The flags are returned by updating the variable pointed to
5770 * by the last parameter.
5771 *
5772 * Side effects:
5773 * None
5774 *
5775 *----------------------------------------------------------------------
5776 */
5777
5778 int
Tcl_GetEnsembleFlags(Tcl_Interp * interp,Tcl_Command token,int * flagsPtr)5779 Tcl_GetEnsembleFlags(
5780 Tcl_Interp *interp,
5781 Tcl_Command token,
5782 int *flagsPtr)
5783 {
5784 Command *cmdPtr = (Command *) token;
5785 EnsembleConfig *ensemblePtr;
5786
5787 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5788 if (interp != NULL) {
5789 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5790 }
5791 return TCL_ERROR;
5792 }
5793
5794 ensemblePtr = cmdPtr->objClientData;
5795 *flagsPtr = ensemblePtr->flags;
5796 return TCL_OK;
5797 }
5798
5799 /*
5800 *----------------------------------------------------------------------
5801 *
5802 * Tcl_GetEnsembleNamespace --
5803 *
5804 * Get the namespace associated with a particular ensemble.
5805 *
5806 * Results:
5807 * Tcl result code (error if command token does not indicate an
5808 * ensemble). Namespace is returned by updating the variable pointed to
5809 * by the last parameter.
5810 *
5811 * Side effects:
5812 * None
5813 *
5814 *----------------------------------------------------------------------
5815 */
5816
5817 int
Tcl_GetEnsembleNamespace(Tcl_Interp * interp,Tcl_Command token,Tcl_Namespace ** namespacePtrPtr)5818 Tcl_GetEnsembleNamespace(
5819 Tcl_Interp *interp,
5820 Tcl_Command token,
5821 Tcl_Namespace **namespacePtrPtr)
5822 {
5823 Command *cmdPtr = (Command *) token;
5824 EnsembleConfig *ensemblePtr;
5825
5826 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5827 if (interp != NULL) {
5828 Tcl_AppendResult(interp, "command is not an ensemble", NULL);
5829 }
5830 return TCL_ERROR;
5831 }
5832
5833 ensemblePtr = cmdPtr->objClientData;
5834 *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
5835 return TCL_OK;
5836 }
5837
5838 /*
5839 *----------------------------------------------------------------------
5840 *
5841 * Tcl_FindEnsemble --
5842 *
5843 * Given a command name, get the ensemble token for it, allowing for
5844 * [namespace import]s. [Bug 1017022]
5845 *
5846 * Results:
5847 * The token for the ensemble command with the given name, or NULL if the
5848 * command either does not exist or is not an ensemble (when an error
5849 * message will be written into the interp if thats non-NULL).
5850 *
5851 * Side effects:
5852 * None
5853 *
5854 *----------------------------------------------------------------------
5855 */
5856
5857 Tcl_Command
Tcl_FindEnsemble(Tcl_Interp * interp,Tcl_Obj * cmdNameObj,int flags)5858 Tcl_FindEnsemble(
5859 Tcl_Interp *interp, /* Where to do the lookup, and where to write
5860 * the errors if TCL_LEAVE_ERR_MSG is set in
5861 * the flags. */
5862 Tcl_Obj *cmdNameObj, /* Name of command to look up. */
5863 int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
5864 * are probably not useful. */
5865 {
5866 Command *cmdPtr;
5867
5868 cmdPtr = (Command *)
5869 Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
5870 if (cmdPtr == NULL) {
5871 return NULL;
5872 }
5873
5874 if (cmdPtr->objProc != NsEnsembleImplementationCmd) {
5875 /*
5876 * Reuse existing infrastructure for following import link chains
5877 * rather than duplicating it.
5878 */
5879
5880 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
5881
5882 if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
5883 if (flags & TCL_LEAVE_ERR_MSG) {
5884 Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
5885 "\" is not an ensemble command", NULL);
5886 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
5887 TclGetString(cmdNameObj), NULL);
5888 }
5889 return NULL;
5890 }
5891 }
5892
5893 return (Tcl_Command) cmdPtr;
5894 }
5895
5896 /*
5897 *----------------------------------------------------------------------
5898 *
5899 * Tcl_IsEnsemble --
5900 *
5901 * Simple test for ensemble-hood that takes into account imported
5902 * ensemble commands as well.
5903 *
5904 * Results:
5905 * Boolean value
5906 *
5907 * Side effects:
5908 * None
5909 *
5910 *----------------------------------------------------------------------
5911 */
5912
5913 int
Tcl_IsEnsemble(Tcl_Command token)5914 Tcl_IsEnsemble(
5915 Tcl_Command token)
5916 {
5917 Command *cmdPtr = (Command *) token;
5918 if (cmdPtr->objProc == NsEnsembleImplementationCmd) {
5919 return 1;
5920 }
5921 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
5922 if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
5923 return 0;
5924 }
5925 return 1;
5926 }
5927
5928 /*
5929 *----------------------------------------------------------------------
5930 *
5931 * TclMakeEnsemble --
5932 *
5933 * Create an ensemble from a table of implementation commands. The
5934 * ensemble will be subject to (limited) compilation if any of the
5935 * implementation commands are compilable.
5936 *
5937 * Results:
5938 * Handle for the ensemble, or NULL if creation of it fails.
5939 *
5940 * Side effects:
5941 * May advance bytecode compilation epoch.
5942 *
5943 *----------------------------------------------------------------------
5944 */
5945
5946 Tcl_Command
TclMakeEnsemble(Tcl_Interp * interp,const char * name,const EnsembleImplMap map[])5947 TclMakeEnsemble(
5948 Tcl_Interp *interp,
5949 const char *name,
5950 const EnsembleImplMap map[])
5951 {
5952 Tcl_Command ensemble; /* The overall ensemble. */
5953 Tcl_Namespace *tclNsPtr; /* Reference to the "::tcl" namespace. */
5954 Tcl_DString buf;
5955
5956 tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
5957 TCL_CREATE_NS_IF_UNKNOWN);
5958 if (tclNsPtr == NULL) {
5959 Tcl_Panic("unable to find or create ::tcl namespace!");
5960 }
5961 Tcl_DStringInit(&buf);
5962 Tcl_DStringAppend(&buf, "::tcl::", -1);
5963 Tcl_DStringAppend(&buf, name, -1);
5964 tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
5965 TCL_CREATE_NS_IF_UNKNOWN);
5966 if (tclNsPtr == NULL) {
5967 Tcl_Panic("unable to find or create %s namespace!",
5968 Tcl_DStringValue(&buf));
5969 }
5970 ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
5971 TCL_ENSEMBLE_PREFIX);
5972 Tcl_DStringAppend(&buf, "::", -1);
5973 if (ensemble != NULL) {
5974 Tcl_Obj *mapDict;
5975 int i, compile = 0;
5976
5977 TclNewObj(mapDict);
5978 for (i=0 ; map[i].name != NULL ; i++) {
5979 Tcl_Obj *fromObj, *toObj;
5980 Command *cmdPtr;
5981
5982 fromObj = Tcl_NewStringObj(map[i].name, -1);
5983 TclNewStringObj(toObj, Tcl_DStringValue(&buf),
5984 Tcl_DStringLength(&buf));
5985 Tcl_AppendToObj(toObj, map[i].name, -1);
5986 Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
5987 cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
5988 TclGetString(toObj), map[i].proc, NULL, NULL);
5989 cmdPtr->compileProc = map[i].compileProc;
5990 compile |= (map[i].compileProc != NULL);
5991 }
5992 Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
5993 if (compile) {
5994 Tcl_SetEnsembleFlags(interp, ensemble,
5995 TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
5996 }
5997 }
5998 Tcl_DStringFree(&buf);
5999
6000 return ensemble;
6001 }
6002
6003 /*
6004 *----------------------------------------------------------------------
6005 *
6006 * NsEnsembleImplementationCmd --
6007 *
6008 * Implements an ensemble of commands (being those exported by a
6009 * namespace other than the global namespace) as a command with the same
6010 * (short) name as the namespace in the parent namespace.
6011 *
6012 * Results:
6013 * A standard Tcl result code. Will be TCL_ERROR if the command is not an
6014 * unambiguous prefix of any command exported by the ensemble's
6015 * namespace.
6016 *
6017 * Side effects:
6018 * Depends on the command within the namespace that gets executed. If the
6019 * ensemble itself returns TCL_ERROR, a descriptive error message will be
6020 * placed in the interpreter's result.
6021 *
6022 *----------------------------------------------------------------------
6023 */
6024
6025 static int
NsEnsembleImplementationCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])6026 NsEnsembleImplementationCmd(
6027 ClientData clientData,
6028 Tcl_Interp *interp,
6029 int objc,
6030 Tcl_Obj *const objv[])
6031 {
6032 EnsembleConfig *ensemblePtr = clientData;
6033 /* The ensemble itself. */
6034 Tcl_Obj **tempObjv; /* Space used to construct the list of
6035 * arguments to pass to the command that
6036 * implements the ensemble subcommand. */
6037 int result; /* The result of the subcommand execution. */
6038 Tcl_Obj *prefixObj; /* An object containing the prefix words of
6039 * the command that implements the
6040 * subcommand. */
6041 Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
6042 * specified but not yet cached command
6043 * names. */
6044 Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the
6045 * target command prefix. */
6046 int prefixObjc; /* Size of prefixObjv of course! */
6047 int reparseCount = 0; /* Number of reparses. */
6048
6049 if (objc < 2) {
6050 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?");
6051 return TCL_ERROR;
6052 }
6053
6054 restartEnsembleParse:
6055 if (ensemblePtr->nsPtr->flags & NS_DYING) {
6056 /*
6057 * Don't know how we got here, but make things give up quickly.
6058 */
6059
6060 if (!Tcl_InterpDeleted(interp)) {
6061 Tcl_AppendResult(interp,
6062 "ensemble activated for deleted namespace", NULL);
6063 }
6064 return TCL_ERROR;
6065 }
6066
6067 /*
6068 * Determine if the table of subcommands is right. If so, we can just look
6069 * up in there and go straight to dispatch.
6070 */
6071
6072 if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
6073 /*
6074 * Table of subcommands is still valid; therefore there might be a
6075 * valid cache of discovered information which we can reuse. Do the
6076 * check here, and if we're still valid, we can jump straight to the
6077 * part where we do the invocation of the subcommand.
6078 */
6079
6080 if (objv[1]->typePtr == &tclEnsembleCmdType) {
6081 EnsembleCmdRep *ensembleCmd = objv[1]->internalRep.twoPtrValue.ptr1;
6082
6083 if (ensembleCmd->nsPtr == ensemblePtr->nsPtr &&
6084 ensembleCmd->epoch == ensemblePtr->epoch &&
6085 ensembleCmd->token == ensemblePtr->token) {
6086 prefixObj = ensembleCmd->realPrefixObj;
6087 Tcl_IncrRefCount(prefixObj);
6088 goto runResultingSubcommand;
6089 }
6090 }
6091 } else {
6092 BuildEnsembleConfig(ensemblePtr);
6093 ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
6094 }
6095
6096 /*
6097 * Look in the hashtable for the subcommand name; this is the fastest way
6098 * of all.
6099 */
6100
6101 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
6102 TclGetString(objv[1]));
6103 if (hPtr != NULL) {
6104 char *fullName = Tcl_GetHashKey(&ensemblePtr->subcommandTable, hPtr);
6105
6106 prefixObj = Tcl_GetHashValue(hPtr);
6107
6108 /*
6109 * Cache for later in the subcommand object.
6110 */
6111
6112 MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
6113 } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
6114 /*
6115 * Could not map, no prefixing, go to unknown/error handling.
6116 */
6117
6118 goto unknownOrAmbiguousSubcommand;
6119 } else {
6120 /*
6121 * If we've not already confirmed the command with the hash as part of
6122 * building our export table, we need to scan the sorted array for
6123 * matches.
6124 */
6125
6126 char *subcmdName; /* Name of the subcommand, or unique prefix of
6127 * it (will be an error for a non-unique
6128 * prefix). */
6129 char *fullName = NULL; /* Full name of the subcommand. */
6130 int stringLength, i;
6131 int tableLength = ensemblePtr->subcommandTable.numEntries;
6132
6133 subcmdName = TclGetString(objv[1]);
6134 stringLength = objv[1]->length;
6135 for (i=0 ; i<tableLength ; i++) {
6136 register int cmp = strncmp(subcmdName,
6137 ensemblePtr->subcommandArrayPtr[i],
6138 (unsigned) stringLength);
6139
6140 if (cmp == 0) {
6141 if (fullName != NULL) {
6142 /*
6143 * Since there's never the exact-match case to worry about
6144 * (hash search filters this), getting here indicates that
6145 * our subcommand is an ambiguous prefix of (at least) two
6146 * exported subcommands, which is an error case.
6147 */
6148
6149 goto unknownOrAmbiguousSubcommand;
6150 }
6151 fullName = ensemblePtr->subcommandArrayPtr[i];
6152 } else if (cmp < 0) {
6153 /*
6154 * Because we are searching a sorted table, we can now stop
6155 * searching because we have gone past anything that could
6156 * possibly match.
6157 */
6158
6159 break;
6160 }
6161 }
6162 if (fullName == NULL) {
6163 /*
6164 * The subcommand is not a prefix of anything, so bail out!
6165 */
6166
6167 goto unknownOrAmbiguousSubcommand;
6168 }
6169 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
6170 if (hPtr == NULL) {
6171 Tcl_Panic("full name %s not found in supposedly synchronized hash",
6172 fullName);
6173 }
6174 prefixObj = Tcl_GetHashValue(hPtr);
6175
6176 /*
6177 * Cache for later in the subcommand object.
6178 */
6179
6180 MakeCachedEnsembleCommand(objv[1], ensemblePtr, fullName, prefixObj);
6181 }
6182
6183 Tcl_IncrRefCount(prefixObj);
6184 runResultingSubcommand:
6185
6186 /*
6187 * Do the real work of execution of the subcommand by building an array of
6188 * objects (note that this is potentially not the same length as the
6189 * number of arguments to this ensemble command), populating it and then
6190 * feeding it back through the main command-lookup engine. In theory, we
6191 * could look up the command in the namespace ourselves, as we already
6192 * have the namespace in which it is guaranteed to exist, but we don't do
6193 * that (the cacheing of the command object used should help with that.)
6194 */
6195
6196 {
6197 Interp *iPtr = (Interp *) interp;
6198 int isRootEnsemble;
6199 Tcl_Obj *copyObj;
6200
6201 /*
6202 * Get the prefix that we're rewriting to. To do this we need to
6203 * ensure that the internal representation of the list does not change
6204 * so that we can safely keep the internal representations of the
6205 * elements in the list.
6206 */
6207
6208 copyObj = TclListObjCopy(NULL, prefixObj);
6209 TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
6210
6211 /*
6212 * Record what arguments the script sent in so that things like
6213 * Tcl_WrongNumArgs can give the correct error message.
6214 */
6215
6216 isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
6217 if (isRootEnsemble) {
6218 iPtr->ensembleRewrite.sourceObjs = objv;
6219 iPtr->ensembleRewrite.numRemovedObjs = 2;
6220 iPtr->ensembleRewrite.numInsertedObjs = prefixObjc;
6221 } else {
6222 int ni = iPtr->ensembleRewrite.numInsertedObjs;
6223
6224 if (ni < 2) {
6225 iPtr->ensembleRewrite.numRemovedObjs += 2 - ni;
6226 iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-1;
6227 } else {
6228 iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
6229 }
6230 }
6231
6232 /*
6233 * Allocate a workspace and build the list of arguments to pass to the
6234 * target command in it.
6235 */
6236
6237 tempObjv = (Tcl_Obj **) TclStackAlloc(interp,
6238 (int) sizeof(Tcl_Obj *) * (objc - 2 + prefixObjc));
6239 memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc);
6240 memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2));
6241
6242 /*
6243 * Hand off to the target command.
6244 */
6245
6246 result = Tcl_EvalObjv(interp, objc-2+prefixObjc, tempObjv,
6247 TCL_EVAL_INVOKE);
6248
6249 /*
6250 * Clean up.
6251 */
6252
6253 TclStackFree(interp, tempObjv);
6254 Tcl_DecrRefCount(copyObj);
6255 if (isRootEnsemble) {
6256 iPtr->ensembleRewrite.sourceObjs = NULL;
6257 iPtr->ensembleRewrite.numRemovedObjs = 0;
6258 iPtr->ensembleRewrite.numInsertedObjs = 0;
6259 }
6260 }
6261 Tcl_DecrRefCount(prefixObj);
6262 return result;
6263
6264 unknownOrAmbiguousSubcommand:
6265 /*
6266 * Have not been able to match the subcommand asked for with a real
6267 * subcommand that we export. See whether a handler has been registered
6268 * for dealing with this situation. Will only call (at most) once for any
6269 * particular ensemble invocation.
6270 */
6271
6272 if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
6273 int paramc, i;
6274 Tcl_Obj **paramv, *unknownCmd, *ensObj;
6275
6276 unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
6277 TclNewObj(ensObj);
6278 Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
6279 Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
6280 for (i=1 ; i<objc ; i++) {
6281 Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
6282 }
6283 TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv);
6284 Tcl_Preserve(ensemblePtr);
6285 Tcl_IncrRefCount(unknownCmd);
6286 result = Tcl_EvalObjv(interp, paramc, paramv, 0);
6287 if (result == TCL_OK) {
6288 prefixObj = Tcl_GetObjResult(interp);
6289 Tcl_IncrRefCount(prefixObj);
6290 Tcl_DecrRefCount(unknownCmd);
6291 Tcl_Release(ensemblePtr);
6292 Tcl_ResetResult(interp);
6293 if (ensemblePtr->flags & ENS_DEAD) {
6294 Tcl_DecrRefCount(prefixObj);
6295 Tcl_SetResult(interp,
6296 "unknown subcommand handler deleted its ensemble",
6297 TCL_STATIC);
6298 return TCL_ERROR;
6299 }
6300
6301 /*
6302 * Namespace is still there. Check if the result is a valid list.
6303 * If it is, and it is non-empty, that list is what we are using
6304 * as our replacement.
6305 */
6306
6307 if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) {
6308 Tcl_DecrRefCount(prefixObj);
6309 Tcl_AddErrorInfo(interp, "\n while parsing result of "
6310 "ensemble unknown subcommand handler");
6311 return TCL_ERROR;
6312 }
6313 if (prefixObjc > 0) {
6314 goto runResultingSubcommand;
6315 }
6316
6317 /*
6318 * Namespace alive & empty result => reparse.
6319 */
6320
6321 Tcl_DecrRefCount(prefixObj);
6322 goto restartEnsembleParse;
6323 }
6324 if (!Tcl_InterpDeleted(interp)) {
6325 if (result != TCL_ERROR) {
6326 char buf[TCL_INTEGER_SPACE];
6327
6328 Tcl_ResetResult(interp);
6329 Tcl_SetResult(interp,
6330 "unknown subcommand handler returned bad code: ",
6331 TCL_STATIC);
6332 switch (result) {
6333 case TCL_RETURN:
6334 Tcl_AppendResult(interp, "return", NULL);
6335 break;
6336 case TCL_BREAK:
6337 Tcl_AppendResult(interp, "break", NULL);
6338 break;
6339 case TCL_CONTINUE:
6340 Tcl_AppendResult(interp, "continue", NULL);
6341 break;
6342 default:
6343 sprintf(buf, "%d", result);
6344 Tcl_AppendResult(interp, buf, NULL);
6345 }
6346 Tcl_AddErrorInfo(interp, "\n result of "
6347 "ensemble unknown subcommand handler: ");
6348 Tcl_AddErrorInfo(interp, TclGetString(unknownCmd));
6349 } else {
6350 Tcl_AddErrorInfo(interp,
6351 "\n (ensemble unknown subcommand handler)");
6352 }
6353 }
6354 Tcl_DecrRefCount(unknownCmd);
6355 Tcl_Release(ensemblePtr);
6356 return TCL_ERROR;
6357 }
6358
6359 /*
6360 * We cannot determine what subcommand to hand off to, so generate a
6361 * (standard) failure message. Note the one odd case compared with
6362 * standard ensemble-like command, which is where a namespace has no
6363 * exported commands at all...
6364 */
6365
6366 Tcl_ResetResult(interp);
6367 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
6368 TclGetString(objv[1]), NULL);
6369 if (ensemblePtr->subcommandTable.numEntries == 0) {
6370 Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]),
6371 "\": namespace ", ensemblePtr->nsPtr->fullName,
6372 " does not export any commands", NULL);
6373 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
6374 TclGetString(objv[1]), NULL);
6375 return TCL_ERROR;
6376 }
6377 Tcl_AppendResult(interp, "unknown ",
6378 (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? "or ambiguous " : ""),
6379 "subcommand \"", TclGetString(objv[1]), "\": must be ", NULL);
6380 if (ensemblePtr->subcommandTable.numEntries == 1) {
6381 Tcl_AppendResult(interp, ensemblePtr->subcommandArrayPtr[0], NULL);
6382 } else {
6383 int i;
6384
6385 for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
6386 Tcl_AppendResult(interp,
6387 ensemblePtr->subcommandArrayPtr[i], ", ", NULL);
6388 }
6389 Tcl_AppendResult(interp, "or ",
6390 ensemblePtr->subcommandArrayPtr[i], NULL);
6391 }
6392 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
6393 TclGetString(objv[1]), NULL);
6394 return TCL_ERROR;
6395 }
6396
6397 /*
6398 *----------------------------------------------------------------------
6399 *
6400 * MakeCachedEnsembleCommand --
6401 *
6402 * Cache what we've computed so far; it's not nice to repeatedly copy
6403 * strings about. Note that to do this, we start by deleting any old
6404 * representation that there was (though if it was an out of date
6405 * ensemble rep, we can skip some of the deallocation process.)
6406 *
6407 * Results:
6408 * None
6409 *
6410 * Side effects:
6411 * Alters the internal representation of the first object parameter.
6412 *
6413 *----------------------------------------------------------------------
6414 */
6415
6416 static void
MakeCachedEnsembleCommand(Tcl_Obj * objPtr,EnsembleConfig * ensemblePtr,const char * subcommandName,Tcl_Obj * prefixObjPtr)6417 MakeCachedEnsembleCommand(
6418 Tcl_Obj *objPtr,
6419 EnsembleConfig *ensemblePtr,
6420 const char *subcommandName,
6421 Tcl_Obj *prefixObjPtr)
6422 {
6423 register EnsembleCmdRep *ensembleCmd;
6424 int length;
6425
6426 if (objPtr->typePtr == &tclEnsembleCmdType) {
6427 ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
6428 Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
6429 ensembleCmd->nsPtr->refCount--;
6430 if ((ensembleCmd->nsPtr->refCount == 0)
6431 && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
6432 NamespaceFree(ensembleCmd->nsPtr);
6433 }
6434 ckfree(ensembleCmd->fullSubcmdName);
6435 } else {
6436 /*
6437 * Kill the old internal rep, and replace it with a brand new one of
6438 * our own.
6439 */
6440
6441 TclFreeIntRep(objPtr);
6442 ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
6443 objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd;
6444 objPtr->typePtr = &tclEnsembleCmdType;
6445 }
6446
6447 /*
6448 * Populate the internal rep.
6449 */
6450
6451 ensembleCmd->nsPtr = ensemblePtr->nsPtr;
6452 ensembleCmd->epoch = ensemblePtr->epoch;
6453 ensembleCmd->token = ensemblePtr->token;
6454 ensemblePtr->nsPtr->refCount++;
6455 ensembleCmd->realPrefixObj = prefixObjPtr;
6456 length = strlen(subcommandName)+1;
6457 ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
6458 memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
6459 Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
6460 }
6461
6462 /*
6463 *----------------------------------------------------------------------
6464 *
6465 * DeleteEnsembleConfig --
6466 *
6467 * Destroys the data structure used to represent an ensemble. This is
6468 * called when the ensemble's command is deleted (which happens
6469 * automatically if the ensemble's namespace is deleted.) Maintainers
6470 * should note that ensembles should be deleted by deleting their
6471 * commands.
6472 *
6473 * Results:
6474 * None.
6475 *
6476 * Side effects:
6477 * Memory is (eventually) deallocated.
6478 *
6479 *----------------------------------------------------------------------
6480 */
6481
6482 static void
DeleteEnsembleConfig(ClientData clientData)6483 DeleteEnsembleConfig(
6484 ClientData clientData)
6485 {
6486 EnsembleConfig *ensemblePtr = clientData;
6487 Namespace *nsPtr = ensemblePtr->nsPtr;
6488 Tcl_HashSearch search;
6489 Tcl_HashEntry *hEnt;
6490
6491 /*
6492 * Unlink from the ensemble chain if it has not been marked as having been
6493 * done already.
6494 */
6495
6496 if (ensemblePtr->next != ensemblePtr) {
6497 EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
6498 if (ensPtr == ensemblePtr) {
6499 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
6500 } else {
6501 while (ensPtr != NULL) {
6502 if (ensPtr->next == ensemblePtr) {
6503 ensPtr->next = ensemblePtr->next;
6504 break;
6505 }
6506 ensPtr = ensPtr->next;
6507 }
6508 }
6509 }
6510
6511 /*
6512 * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
6513 * whether disaster happened anyway.
6514 */
6515
6516 ensemblePtr->flags |= ENS_DEAD;
6517
6518 /*
6519 * Kill the pointer-containing fields.
6520 */
6521
6522 if (ensemblePtr->subcommandTable.numEntries != 0) {
6523 ckfree((char *) ensemblePtr->subcommandArrayPtr);
6524 }
6525 hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
6526 while (hEnt != NULL) {
6527 Tcl_Obj *prefixObj = Tcl_GetHashValue(hEnt);
6528
6529 Tcl_DecrRefCount(prefixObj);
6530 hEnt = Tcl_NextHashEntry(&search);
6531 }
6532 Tcl_DeleteHashTable(&ensemblePtr->subcommandTable);
6533 if (ensemblePtr->subcmdList != NULL) {
6534 Tcl_DecrRefCount(ensemblePtr->subcmdList);
6535 }
6536 if (ensemblePtr->subcommandDict != NULL) {
6537 Tcl_DecrRefCount(ensemblePtr->subcommandDict);
6538 }
6539 if (ensemblePtr->unknownHandler != NULL) {
6540 Tcl_DecrRefCount(ensemblePtr->unknownHandler);
6541 }
6542
6543 /*
6544 * Arrange for the structure to be reclaimed. Note that this is complex
6545 * because we have to make sure that we can react sensibly when an
6546 * ensemble is deleted during the process of initialising the ensemble
6547 * (especially the unknown callback.)
6548 */
6549
6550 Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
6551 }
6552
6553 /*
6554 *----------------------------------------------------------------------
6555 *
6556 * BuildEnsembleConfig --
6557 *
6558 * Create the internal data structures that describe how an ensemble
6559 * looks, being a hash mapping from the full command name to the Tcl list
6560 * that describes the implementation prefix words, and a sorted array of
6561 * all the full command names to allow for reasonably efficient
6562 * unambiguous prefix handling.
6563 *
6564 * Results:
6565 * None.
6566 *
6567 * Side effects:
6568 * Reallocates and rebuilds the hash table and array stored at the
6569 * ensemblePtr argument. For large ensembles or large namespaces, this is
6570 * a potentially expensive operation.
6571 *
6572 *----------------------------------------------------------------------
6573 */
6574
6575 static void
BuildEnsembleConfig(EnsembleConfig * ensemblePtr)6576 BuildEnsembleConfig(
6577 EnsembleConfig *ensemblePtr)
6578 {
6579 Tcl_HashSearch search; /* Used for scanning the set of commands in
6580 * the namespace that backs up this
6581 * ensemble. */
6582 int i, j, isNew;
6583 Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
6584 Tcl_HashEntry *hPtr;
6585
6586 if (hash->numEntries != 0) {
6587 /*
6588 * Remove pre-existing table.
6589 */
6590
6591 Tcl_HashSearch search;
6592
6593 ckfree((char *) ensemblePtr->subcommandArrayPtr);
6594 hPtr = Tcl_FirstHashEntry(hash, &search);
6595 while (hPtr != NULL) {
6596 Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
6597 Tcl_DecrRefCount(prefixObj);
6598 hPtr = Tcl_NextHashEntry(&search);
6599 }
6600 Tcl_DeleteHashTable(hash);
6601 Tcl_InitHashTable(hash, TCL_STRING_KEYS);
6602 }
6603
6604 /*
6605 * See if we've got an export list. If so, we will only export exactly
6606 * those commands, which may be either implemented by the prefix in the
6607 * subcommandDict or mapped directly onto the namespace's commands.
6608 */
6609
6610 if (ensemblePtr->subcmdList != NULL) {
6611 Tcl_Obj **subcmdv, *target, *cmdObj, *cmdPrefixObj;
6612 int subcmdc;
6613
6614 TclListObjGetElements(NULL, ensemblePtr->subcmdList, &subcmdc,
6615 &subcmdv);
6616 for (i=0 ; i<subcmdc ; i++) {
6617 char *name = TclGetString(subcmdv[i]);
6618
6619 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
6620
6621 /*
6622 * Skip non-unique cases.
6623 */
6624
6625 if (!isNew) {
6626 continue;
6627 }
6628
6629 /*
6630 * Look in our dictionary (if present) for the command.
6631 */
6632
6633 if (ensemblePtr->subcommandDict != NULL) {
6634 Tcl_DictObjGet(NULL, ensemblePtr->subcommandDict, subcmdv[i],
6635 &target);
6636 if (target != NULL) {
6637 Tcl_SetHashValue(hPtr, target);
6638 Tcl_IncrRefCount(target);
6639 continue;
6640 }
6641 }
6642
6643 /*
6644 * Not there, so map onto the namespace. Note in this case that we
6645 * do not guarantee that the command is actually there; that is
6646 * the programmer's responsibility (or [::unknown] of course).
6647 */
6648
6649 cmdObj = Tcl_NewStringObj(ensemblePtr->nsPtr->fullName, -1);
6650 if (ensemblePtr->nsPtr->parentPtr != NULL) {
6651 Tcl_AppendStringsToObj(cmdObj, "::", name, NULL);
6652 } else {
6653 Tcl_AppendStringsToObj(cmdObj, name, NULL);
6654 }
6655 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
6656 Tcl_SetHashValue(hPtr, cmdPrefixObj);
6657 Tcl_IncrRefCount(cmdPrefixObj);
6658 }
6659 } else if (ensemblePtr->subcommandDict != NULL) {
6660 /*
6661 * No subcmd list, but we do have a mapping dictionary so we should
6662 * use the keys of that. Convert the dictionary's contents into the
6663 * form required for the ensemble's internal hashtable.
6664 */
6665
6666 Tcl_DictSearch dictSearch;
6667 Tcl_Obj *keyObj, *valueObj;
6668 int done;
6669
6670 Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
6671 &keyObj, &valueObj, &done);
6672 while (!done) {
6673 char *name = TclGetString(keyObj);
6674
6675 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
6676 Tcl_SetHashValue(hPtr, valueObj);
6677 Tcl_IncrRefCount(valueObj);
6678 Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
6679 }
6680 } else {
6681 /*
6682 * Discover what commands are actually exported by the namespace.
6683 * What we have is an array of patterns and a hash table whose keys
6684 * are the command names exported by the namespace (the contents do
6685 * not matter here.) We must find out what commands are actually
6686 * exported by filtering each command in the namespace against each of
6687 * the patterns in the export list. Note that we use an intermediate
6688 * hash table to make memory management easier, and because that makes
6689 * exact matching far easier too.
6690 *
6691 * Suggestion for future enhancement: compute the unique prefixes and
6692 * place them in the hash too, which should make for even faster
6693 * matching.
6694 */
6695
6696 hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
6697 for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
6698 char *nsCmdName = /* Name of command in namespace. */
6699 Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
6700
6701 for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
6702 if (Tcl_StringMatch(nsCmdName,
6703 ensemblePtr->nsPtr->exportArrayPtr[i])) {
6704 hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
6705
6706 /*
6707 * Remember, hash entries have a full reference to the
6708 * substituted part of the command (as a list) as their
6709 * content!
6710 */
6711
6712 if (isNew) {
6713 Tcl_Obj *cmdObj, *cmdPrefixObj;
6714
6715 TclNewObj(cmdObj);
6716 Tcl_AppendStringsToObj(cmdObj,
6717 ensemblePtr->nsPtr->fullName,
6718 (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
6719 nsCmdName, NULL);
6720 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
6721 Tcl_SetHashValue(hPtr, cmdPrefixObj);
6722 Tcl_IncrRefCount(cmdPrefixObj);
6723 }
6724 break;
6725 }
6726 }
6727 }
6728 }
6729
6730 if (hash->numEntries == 0) {
6731 ensemblePtr->subcommandArrayPtr = NULL;
6732 return;
6733 }
6734
6735 /*
6736 * Create a sorted array of all subcommands in the ensemble; hash tables
6737 * are all very well for a quick look for an exact match, but they can't
6738 * determine things like whether a string is a prefix of another (not
6739 * without lots of preparation anyway) and they're no good for when we're
6740 * generating the error message either.
6741 *
6742 * We do this by filling an array with the names (we use the hash keys
6743 * directly to save a copy, since any time we change the array we change
6744 * the hash too, and vice versa) and running quicksort over the array.
6745 */
6746
6747 ensemblePtr->subcommandArrayPtr = (char **)
6748 ckalloc(sizeof(char *) * hash->numEntries);
6749
6750 /*
6751 * Fill array from both ends as this makes us less likely to end up with
6752 * performance problems in qsort(), which is good. Note that doing this
6753 * makes this code much more opaque, but the naive alternatve:
6754 *
6755 * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
6756 * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
6757 * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
6758 * }
6759 *
6760 * can produce long runs of precisely ordered table entries when the
6761 * commands in the namespace are declared in a sorted fashion (an ordering
6762 * some people like) and the hashing functions (or the command names
6763 * themselves) are fairly unfortunate. By filling from both ends, it
6764 * requires active malice (and probably a debugger) to get qsort() to have
6765 * awful runtime behaviour.
6766 */
6767
6768 i = 0;
6769 j = hash->numEntries;
6770 hPtr = Tcl_FirstHashEntry(hash, &search);
6771 while (hPtr != NULL) {
6772 ensemblePtr->subcommandArrayPtr[i++] = Tcl_GetHashKey(hash, hPtr);
6773 hPtr = Tcl_NextHashEntry(&search);
6774 if (hPtr == NULL) {
6775 break;
6776 }
6777 ensemblePtr->subcommandArrayPtr[--j] = Tcl_GetHashKey(hash, hPtr);
6778 hPtr = Tcl_NextHashEntry(&search);
6779 }
6780 if (hash->numEntries > 1) {
6781 qsort(ensemblePtr->subcommandArrayPtr, (unsigned)hash->numEntries,
6782 sizeof(char *), NsEnsembleStringOrder);
6783 }
6784 }
6785
6786 /*
6787 *----------------------------------------------------------------------
6788 *
6789 * NsEnsembleStringOrder --
6790 *
6791 * Helper function to compare two pointers to two strings for use with
6792 * qsort().
6793 *
6794 * Results:
6795 * -1 if the first string is smaller, 1 if the second string is smaller,
6796 * and 0 if they are equal.
6797 *
6798 * Side effects:
6799 * None.
6800 *
6801 *----------------------------------------------------------------------
6802 */
6803
6804 static int
NsEnsembleStringOrder(const void * strPtr1,const void * strPtr2)6805 NsEnsembleStringOrder(
6806 const void *strPtr1,
6807 const void *strPtr2)
6808 {
6809 return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
6810 }
6811
6812 /*
6813 *----------------------------------------------------------------------
6814 *
6815 * FreeEnsembleCmdRep --
6816 *
6817 * Destroys the internal representation of a Tcl_Obj that has been
6818 * holding information about a command in an ensemble.
6819 *
6820 * Results:
6821 * None.
6822 *
6823 * Side effects:
6824 * Memory is deallocated. If this held the last reference to a
6825 * namespace's main structure, that main structure will also be
6826 * destroyed.
6827 *
6828 *----------------------------------------------------------------------
6829 */
6830
6831 static void
FreeEnsembleCmdRep(Tcl_Obj * objPtr)6832 FreeEnsembleCmdRep(
6833 Tcl_Obj *objPtr)
6834 {
6835 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
6836
6837 Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
6838 ckfree(ensembleCmd->fullSubcmdName);
6839 ensembleCmd->nsPtr->refCount--;
6840 if ((ensembleCmd->nsPtr->refCount == 0)
6841 && (ensembleCmd->nsPtr->flags & NS_DEAD)) {
6842 NamespaceFree(ensembleCmd->nsPtr);
6843 }
6844 ckfree((char *) ensembleCmd);
6845 }
6846
6847 /*
6848 *----------------------------------------------------------------------
6849 *
6850 * DupEnsembleCmdRep --
6851 *
6852 * Makes one Tcl_Obj into a copy of another that is a subcommand of an
6853 * ensemble.
6854 *
6855 * Results:
6856 * None.
6857 *
6858 * Side effects:
6859 * Memory is allocated, and the namespace that the ensemble is built on
6860 * top of gains another reference.
6861 *
6862 *----------------------------------------------------------------------
6863 */
6864
6865 static void
DupEnsembleCmdRep(Tcl_Obj * objPtr,Tcl_Obj * copyPtr)6866 DupEnsembleCmdRep(
6867 Tcl_Obj *objPtr,
6868 Tcl_Obj *copyPtr)
6869 {
6870 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
6871 EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
6872 ckalloc(sizeof(EnsembleCmdRep));
6873 int length = strlen(ensembleCmd->fullSubcmdName);
6874
6875 copyPtr->typePtr = &tclEnsembleCmdType;
6876 copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy;
6877 ensembleCopy->nsPtr = ensembleCmd->nsPtr;
6878 ensembleCopy->epoch = ensembleCmd->epoch;
6879 ensembleCopy->token = ensembleCmd->token;
6880 ensembleCopy->nsPtr->refCount++;
6881 ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
6882 Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
6883 ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
6884 memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
6885 (unsigned) length+1);
6886 }
6887
6888 /*
6889 *----------------------------------------------------------------------
6890 *
6891 * StringOfEnsembleCmdRep --
6892 *
6893 * Creates a string representation of a Tcl_Obj that holds a subcommand
6894 * of an ensemble.
6895 *
6896 * Results:
6897 * None.
6898 *
6899 * Side effects:
6900 * The object gains a string (UTF-8) representation.
6901 *
6902 *----------------------------------------------------------------------
6903 */
6904
6905 static void
StringOfEnsembleCmdRep(Tcl_Obj * objPtr)6906 StringOfEnsembleCmdRep(
6907 Tcl_Obj *objPtr)
6908 {
6909 EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1;
6910 int length = strlen(ensembleCmd->fullSubcmdName);
6911
6912 objPtr->length = length;
6913 objPtr->bytes = ckalloc((unsigned) length+1);
6914 memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
6915 }
6916
6917 /*
6918 *----------------------------------------------------------------------
6919 *
6920 * Tcl_LogCommandInfo --
6921 *
6922 * This function is invoked after an error occurs in an interpreter. It
6923 * adds information to iPtr->errorInfo field to describe the command that
6924 * was being executed when the error occurred.
6925 *
6926 * Results:
6927 * None.
6928 *
6929 * Side effects:
6930 * Information about the command is added to errorInfo and the line
6931 * number stored internally in the interpreter is set.
6932 *
6933 *----------------------------------------------------------------------
6934 */
6935
6936 void
Tcl_LogCommandInfo(Tcl_Interp * interp,const char * script,const char * command,int length)6937 Tcl_LogCommandInfo(
6938 Tcl_Interp *interp, /* Interpreter in which to log information. */
6939 const char *script, /* First character in script containing
6940 * command (must be <= command). */
6941 const char *command, /* First character in command that generated
6942 * the error. */
6943 int length) /* Number of bytes in command (-1 means use
6944 * all bytes up to first null byte). */
6945 {
6946 register const char *p;
6947 Interp *iPtr = (Interp *) interp;
6948 int overflow, limit = 150;
6949 Var *varPtr, *arrayPtr;
6950
6951 if (iPtr->flags & ERR_ALREADY_LOGGED) {
6952 /*
6953 * Someone else has already logged error information for this command;
6954 * we shouldn't add anything more.
6955 */
6956
6957 return;
6958 }
6959
6960 /*
6961 * Compute the line number where the error occurred.
6962 */
6963
6964 iPtr->errorLine = 1;
6965 for (p = script; p != command; p++) {
6966 if (*p == '\n') {
6967 iPtr->errorLine++;
6968 }
6969 }
6970
6971 if (length < 0) {
6972 length = strlen(command);
6973 }
6974 overflow = (length > limit);
6975 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
6976 "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL)
6977 ? "while executing" : "invoked from within"),
6978 (overflow ? limit : length), command, (overflow ? "..." : "")));
6979
6980 varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY,
6981 NULL, 0, 0, &arrayPtr);
6982 if ((varPtr == NULL) || !TclIsVarTraced(varPtr)) {
6983 /*
6984 * Should not happen.
6985 */
6986
6987 return;
6988 } else {
6989 Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varTraces,
6990 (char *) varPtr);
6991 VarTrace *tracePtr = Tcl_GetHashValue(hPtr);
6992
6993 if (tracePtr->traceProc != EstablishErrorInfoTraces) {
6994 /*
6995 * The most recent trace set on ::errorInfo is not the one the
6996 * core itself puts on last. This means some other code is tracing
6997 * the variable, and the additional trace(s) might be write traces
6998 * that expect the timing of writes to ::errorInfo that existed
6999 * Tcl releases before 8.5. To satisfy that compatibility need, we
7000 * write the current -errorinfo value to the ::errorInfo variable.
7001 */
7002
7003 Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, iPtr->errorInfo,
7004 TCL_GLOBAL_ONLY);
7005 }
7006 }
7007 }
7008
7009 /*
7010 * Local Variables:
7011 * mode: c
7012 * c-basic-offset: 4
7013 * fill-column: 78
7014 * End:
7015 */
7016