1 /*
2 * bltNsUtil.c --
3 *
4 * This module implements utility procedures for namespaces
5 * in the BLT toolkit.
6 *
7 * Copyright 1991-1998 Lucent Technologies, Inc.
8 *
9 * Permission to use, copy, modify, and distribute this software and
10 * its documentation for any purpose and without fee is hereby
11 * granted, provided that the above copyright notice appear in all
12 * copies and that both that the copyright notice and warranty
13 * disclaimer appear in supporting documentation, and that the names
14 * of Lucent Technologies any of their entities not be used in
15 * advertising or publicity pertaining to distribution of the software
16 * without specific, written prior permission.
17 *
18 * Lucent Technologies disclaims all warranties with regard to this
19 * software, including all implied warranties of merchantability and
20 * fitness. In no event shall Lucent Technologies be liable for any
21 * special, indirect or consequential damages or any damages
22 * whatsoever resulting from loss of use, data or profits, whether in
23 * an action of contract, negligence or other tortuous action, arising
24 * out of or in connection with the use or performance of this
25 * software.
26 */
27
28 #include "bltInt.h"
29 #include "bltList.h"
30 #include <tclInt.h>
31
32 /* Namespace related routines */
33
34 /*
35 * ----------------------------------------------------------------------
36 *
37 * Blt_GetVariableNamespace --
38 *
39 * Returns the namespace context of the vector variable. If NULL,
40 * this indicates that the variable is local to the call frame.
41 *
42 * Note the ever-dangerous manner in which we get this information.
43 * All of these structures are "private". Now who's calling Tcl
44 * an "extension" language?
45 *
46 * Results:
47 * Returns the context of the namespace in an opaque type.
48 *
49 * ----------------------------------------------------------------------
50 */
51
52
53 /*
54 * A Command structure exists for each command in a namespace. The
55 * Tcl_Command opaque type actually refers to these structures.
56 */
57
58 Tcl_Namespace *
Blt_GetVariableNamespace(interp,name)59 Blt_GetVariableNamespace(interp, name)
60 Tcl_Interp *interp;
61 CONST char *name;
62 {
63 Tcl_Var varPtr;
64 Tcl_Namespace *nsPtr;
65 Tcl_Obj *objPtr;
66 const char *str, *cp;
67
68 varPtr = Tcl_FindNamespaceVar(interp, (char *)name,
69 (Tcl_Namespace *)NULL, 0);
70 if (varPtr == NULL) {
71 return NULL;
72 }
73 objPtr = Tcl_NewObj();
74 Tcl_GetVariableFullName(interp, varPtr, objPtr);
75 str = Tcl_GetString(objPtr);
76 if (Blt_ParseQualifiedName(interp, str, &nsPtr, &cp) != TCL_OK) {
77 nsPtr = NULL;
78 }
79 Tcl_DecrRefCount(objPtr);
80 return nsPtr;
81 }
82
83 /*ARGSUSED*/
84 Tcl_Namespace *
Blt_GetCommandNamespace(interp,cmdToken)85 Blt_GetCommandNamespace(interp, cmdToken)
86 Tcl_Interp *interp; /* Not used. */
87 Tcl_Command cmdToken;
88 {
89 Tcl_CmdInfo info;
90
91 if (Tcl_GetCommandInfoFromToken(cmdToken, &info) == 0) {
92 return NULL;
93 }
94 return info.namespacePtr;
95 }
96
97 Tcl_CallFrame *
Blt_EnterNamespace(interp,nsPtr)98 Blt_EnterNamespace(interp, nsPtr)
99 Tcl_Interp *interp;
100 Tcl_Namespace *nsPtr;
101 {
102 Tcl_CallFrame *framePtr;
103
104 framePtr = Blt_Malloc(sizeof(Tcl_CallFrame));
105 assert(framePtr);
106 if (Tcl_PushCallFrame(interp, framePtr, (Tcl_Namespace *)nsPtr, 0)
107 != TCL_OK) {
108 Blt_Free(framePtr);
109 return NULL;
110 }
111 return framePtr;
112 }
113
114 void
Blt_LeaveNamespace(interp,framePtr)115 Blt_LeaveNamespace(interp, framePtr)
116 Tcl_Interp *interp;
117 Tcl_CallFrame *framePtr;
118 {
119 Tcl_PopCallFrame(interp);
120 Blt_Free(framePtr);
121 }
122
123 int
Blt_ParseQualifiedName(interp,qualName,nsPtrPtr,namePtrPtr)124 Blt_ParseQualifiedName(interp, qualName, nsPtrPtr, namePtrPtr)
125 Tcl_Interp *interp;
126 CONST char *qualName;
127 Tcl_Namespace **nsPtrPtr;
128 CONST char **namePtrPtr;
129 {
130 register char *p, *colon;
131 Tcl_Namespace *nsPtr;
132
133 colon = NULL;
134 p = (char *)(qualName + strlen(qualName));
135 while (--p > qualName) {
136 if ((*p == ':') && (*(p - 1) == ':')) {
137 p++; /* just after the last "::" */
138 colon = p - 2;
139 break;
140 }
141 }
142 if (colon == NULL) {
143 *nsPtrPtr = NULL;
144 *namePtrPtr = (char *)qualName;
145 return TCL_OK;
146 }
147 *colon = '\0';
148 if (qualName[0] == '\0') {
149 nsPtr = Tcl_GetGlobalNamespace(interp);
150 } else {
151 nsPtr = Tcl_FindNamespace(interp, (char *)qualName,
152 (Tcl_Namespace *)NULL, 0);
153 }
154 *colon = ':';
155 if (nsPtr == NULL) {
156 return TCL_ERROR;
157 }
158 *nsPtrPtr = nsPtr;
159 *namePtrPtr = p;
160 return TCL_OK;
161 }
162
163 char *
Blt_GetQualifiedName(nsPtr,name,resultPtr)164 Blt_GetQualifiedName(nsPtr, name, resultPtr)
165 Tcl_Namespace *nsPtr;
166 CONST char *name;
167 Tcl_DString *resultPtr;
168 {
169 Tcl_DStringInit(resultPtr);
170 if ((nsPtr->fullName[0] != ':') || (nsPtr->fullName[1] != ':') ||
171 (nsPtr->fullName[2] != '\0')) {
172 Tcl_DStringAppend(resultPtr, nsPtr->fullName, -1);
173 }
174 Tcl_DStringAppend(resultPtr, "::", -1);
175 Tcl_DStringAppend(resultPtr, (char *)name, -1);
176 return Tcl_DStringValue(resultPtr);
177 }
178
179
180 typedef struct {
181 Tcl_HashTable clientTable;
182
183 /* Original clientdata and delete procedure. */
184 ClientData origClientData;
185 Tcl_NamespaceDeleteProc *origDeleteProc;
186
187 } Callback;
188
189 static Tcl_CmdProc NamespaceDeleteCmd;
190 static Tcl_NamespaceDeleteProc NamespaceDeleteNotify;
191
192 #define NS_DELETE_CMD "#NamespaceDeleteNotifier"
193
194 /*ARGSUSED*/
195 static int
NamespaceDeleteCmd(clientData,interp,argc,argv)196 NamespaceDeleteCmd(clientData, interp, argc, argv)
197 ClientData clientData; /* Not used. */
198 Tcl_Interp *interp; /* */
199 int argc;
200 char **argv;
201 {
202 Tcl_AppendResult(interp, "command \"", argv[0], "\" shouldn't be invoked",
203 (char *)NULL);
204 return TCL_ERROR;
205 }
206
207 static void
NamespaceDeleteNotify(clientData)208 NamespaceDeleteNotify(clientData)
209 ClientData clientData;
210 {
211 Blt_List list;
212 Blt_ListNode node;
213 Tcl_CmdDeleteProc *deleteProc;
214
215 list = (Blt_List)clientData;
216 for (node = Blt_ListFirstNode(list); node != NULL;
217 node = Blt_ListNextNode(node)) {
218 deleteProc = (Tcl_CmdDeleteProc *)Blt_ListGetValue(node);
219 clientData = (ClientData)Blt_ListGetKey(node);
220 (*deleteProc) (clientData);
221 }
222 Blt_ListDestroy(list);
223 }
224
225 void
Blt_DestroyNsDeleteNotify(interp,nsPtr,clientData)226 Blt_DestroyNsDeleteNotify(interp, nsPtr, clientData)
227 Tcl_Interp *interp;
228 Tcl_Namespace *nsPtr;
229 ClientData clientData;
230 {
231 Blt_List list;
232 Blt_ListNode node;
233 char *string;
234 Tcl_CmdInfo cmdInfo;
235
236 string = Blt_Malloc(sizeof(nsPtr->fullName) + strlen(NS_DELETE_CMD) + 4);
237 strcpy(string, nsPtr->fullName);
238 strcat(string, "::");
239 strcat(string, NS_DELETE_CMD);
240 if (!Tcl_GetCommandInfo(interp, string, &cmdInfo)) {
241 goto done;
242 }
243 list = (Blt_List)cmdInfo.clientData;
244 node = Blt_ListGetNode(list, clientData);
245 if (node != NULL) {
246 Blt_ListDeleteNode(node);
247 }
248 done:
249 Blt_Free(string);
250 }
251
252 int
Blt_CreateNsDeleteNotify(interp,nsPtr,clientData,deleteProc)253 Blt_CreateNsDeleteNotify(interp, nsPtr, clientData, deleteProc)
254 Tcl_Interp *interp;
255 Tcl_Namespace *nsPtr;
256 ClientData clientData;
257 Tcl_CmdDeleteProc *deleteProc;
258 {
259 Blt_List list;
260 char *string;
261 Tcl_CmdInfo cmdInfo;
262
263 string = Blt_Malloc(sizeof(nsPtr->fullName) + strlen(NS_DELETE_CMD) + 4);
264 strcpy(string, nsPtr->fullName);
265 strcat(string, "::");
266 strcat(string, NS_DELETE_CMD);
267 if (!Tcl_GetCommandInfo(interp, string, &cmdInfo)) {
268 list = Blt_ListCreate(BLT_ONE_WORD_KEYS);
269 Blt_CreateCommand(interp, string, NamespaceDeleteCmd, list,
270 NamespaceDeleteNotify);
271 } else {
272 list = (Blt_List)cmdInfo.clientData;
273 }
274 Blt_Free(string);
275 Blt_ListAppend(list, clientData, (ClientData)deleteProc);
276 return TCL_OK;
277 }
278
279 /*
280 *----------------------------------------------------------------------
281 *
282 * Blt_CreateCommand --
283 *
284 * Like Tcl_CreateCommand, but creates command in current namespace
285 * instead of global, if one isn't defined. Not a problem with
286 * [incr Tcl] namespaces.
287 *
288 * Results:
289 * The return value is a token for the command, which can
290 * be used in future calls to Tcl_GetCommandName.
291 *
292 *----------------------------------------------------------------------
293 */
294 Tcl_Command
Blt_CreateCommand(interp,cmdName,proc,clientData,deleteProc)295 Blt_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
296 Tcl_Interp *interp; /* Token for command interpreter returned by
297 * a previous call to Tcl_CreateInterp. */
298 CONST char *cmdName; /* Name of command. If it contains namespace
299 * qualifiers, the new command is put in the
300 * specified namespace; otherwise it is put
301 * in the global namespace. */
302 Tcl_CmdProc *proc; /* Procedure to associate with cmdName. */
303 ClientData clientData; /* Arbitrary value passed to string proc. */
304 Tcl_CmdDeleteProc *deleteProc;
305 /* If not NULL, gives a procedure to call
306
307 * when this command is deleted. */
308 {
309 register CONST char *p;
310
311 p = cmdName + strlen(cmdName);
312 while (--p > cmdName) {
313 if ((*p == ':') && (*(p - 1) == ':')) {
314 p++; /* just after the last "::" */
315 break;
316 }
317 }
318 if (cmdName == p) {
319 Tcl_DString dString;
320 Tcl_Namespace *nsPtr;
321 Tcl_Command cmdToken;
322
323 Tcl_DStringInit(&dString);
324 nsPtr = Tcl_GetCurrentNamespace(interp);
325 Tcl_DStringAppend(&dString, nsPtr->fullName, -1);
326 Tcl_DStringAppend(&dString, "::", -1);
327 Tcl_DStringAppend(&dString, cmdName, -1);
328 cmdToken = Tcl_CreateCommand(interp, Tcl_DStringValue(&dString), proc,
329 clientData, deleteProc);
330 Tcl_DStringFree(&dString);
331 return cmdToken;
332 }
333 return Tcl_CreateCommand(interp, (char *)cmdName, proc, clientData,
334 deleteProc);
335 }
336
337 /*
338 *----------------------------------------------------------------------
339 *
340 * Blt_CreateCommandObj --
341 *
342 * Like Tcl_CreateCommand, but creates command in current namespace
343 * instead of global, if one isn't defined. Not a problem with
344 * [incr Tcl] namespaces.
345 *
346 * Results:
347 * The return value is a token for the command, which can
348 * be used in future calls to Tcl_GetCommandName.
349 *
350 *----------------------------------------------------------------------
351 */
352 Tcl_Command
Blt_CreateCommandObj(interp,cmdName,proc,clientData,deleteProc)353 Blt_CreateCommandObj(interp, cmdName, proc, clientData, deleteProc)
354 Tcl_Interp *interp; /* Token for command interpreter returned by
355 * a previous call to Tcl_CreateInterp. */
356 CONST char *cmdName; /* Name of command. If it contains namespace
357 * qualifiers, the new command is put in the
358 * specified namespace; otherwise it is put
359 * in the global namespace. */
360 Tcl_ObjCmdProc *proc; /* Procedure to associate with cmdName. */
361 ClientData clientData; /* Arbitrary value passed to string proc. */
362 Tcl_CmdDeleteProc *deleteProc;
363 /* If not NULL, gives a procedure to call
364 * when this command is deleted. */
365 {
366 register CONST char *p;
367
368 p = cmdName + strlen(cmdName);
369 while (--p > cmdName) {
370 if ((*p == ':') && (*(p - 1) == ':')) {
371 p++; /* just after the last "::" */
372 break;
373 }
374 }
375 if (cmdName == p) {
376 Tcl_DString dString;
377 Tcl_Namespace *nsPtr;
378 Tcl_Command cmdToken;
379
380 Tcl_DStringInit(&dString);
381 nsPtr = Tcl_GetCurrentNamespace(interp);
382 Tcl_DStringAppend(&dString, nsPtr->fullName, -1);
383 Tcl_DStringAppend(&dString, "::", -1);
384 Tcl_DStringAppend(&dString, cmdName, -1);
385 cmdToken = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&dString),
386 proc, clientData, deleteProc);
387 Tcl_DStringFree(&dString);
388 return cmdToken;
389 }
390 return Tcl_CreateObjCommand(interp, (char *)cmdName, proc, clientData,
391 deleteProc);
392 }
393