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