1 /*
2 * tclEnsemble.c --
3 *
4 * Contains support for ensembles (see TIP#112), which provide simple
5 * mechanism for creating composite commands on top of namespaces.
6 *
7 * Copyright © 2005-2013 Donal K. Fellows.
8 *
9 * See the file "license.terms" for information on usage and redistribution of
10 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
11 */
12
13 #include "tclInt.h"
14 #include "tclCompile.h"
15
16 /*
17 * Declarations for functions local to this file:
18 */
19
20 static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr);
21 static inline int EnsembleUnknownCallback(Tcl_Interp *interp,
22 EnsembleConfig *ensemblePtr, int objc,
23 Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr);
24 static int NsEnsembleImplementationCmdNR(ClientData clientData,
25 Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
26 static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr);
27 static int NsEnsembleStringOrder(const void *strPtr1,
28 const void *strPtr2);
29 static void DeleteEnsembleConfig(ClientData clientData);
30 static void MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
31 EnsembleConfig *ensemblePtr, Tcl_HashEntry *hPtr,
32 Tcl_Obj *fix);
33 static void FreeEnsembleCmdRep(Tcl_Obj *objPtr);
34 static void DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
35 static void CompileToInvokedCommand(Tcl_Interp *interp,
36 Tcl_Parse *parsePtr, Tcl_Obj *replacements,
37 Command *cmdPtr, CompileEnv *envPtr);
38 static int CompileBasicNArgCommand(Tcl_Interp *interp,
39 Tcl_Parse *parsePtr, Command *cmdPtr,
40 CompileEnv *envPtr);
41
42 static Tcl_NRPostProc FreeER;
43
44 /*
45 * The lists of subcommands and options for the [namespace ensemble] command.
46 */
47
48 static const char *const ensembleSubcommands[] = {
49 "configure", "create", "exists", NULL
50 };
51 enum EnsSubcmds {
52 ENS_CONFIG, ENS_CREATE, ENS_EXISTS
53 };
54
55 static const char *const ensembleCreateOptions[] = {
56 "-command", "-map", "-parameters", "-prefixes", "-subcommands",
57 "-unknown", NULL
58 };
59 enum EnsCreateOpts {
60 CRT_CMD, CRT_MAP, CRT_PARAM, CRT_PREFIX, CRT_SUBCMDS, CRT_UNKNOWN
61 };
62
63 static const char *const ensembleConfigOptions[] = {
64 "-map", "-namespace", "-parameters", "-prefixes", "-subcommands",
65 "-unknown", NULL
66 };
67 enum EnsConfigOpts {
68 CONF_MAP, CONF_NAMESPACE, CONF_PARAM, CONF_PREFIX, CONF_SUBCMDS,
69 CONF_UNKNOWN
70 };
71
72 /*
73 * This structure defines a Tcl object type that contains a reference to an
74 * ensemble subcommand (e.g. the "length" in [string length ab]). It is used
75 * to cache the mapping between the subcommand itself and the real command
76 * that implements it.
77 */
78
79 static const Tcl_ObjType ensembleCmdType = {
80 "ensembleCommand", /* the type's name */
81 FreeEnsembleCmdRep, /* freeIntRepProc */
82 DupEnsembleCmdRep, /* dupIntRepProc */
83 NULL, /* updateStringProc */
84 NULL /* setFromAnyProc */
85 };
86
87 #define ECRSetIntRep(objPtr, ecRepPtr) \
88 do { \
89 Tcl_ObjIntRep ir; \
90 ir.twoPtrValue.ptr1 = (ecRepPtr); \
91 ir.twoPtrValue.ptr2 = NULL; \
92 Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \
93 } while (0)
94
95 #define ECRGetIntRep(objPtr, ecRepPtr) \
96 do { \
97 const Tcl_ObjIntRep *irPtr; \
98 irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \
99 (ecRepPtr) = irPtr ? (EnsembleCmdRep *)irPtr->twoPtrValue.ptr1 : NULL; \
100 } while (0)
101
102 /*
103 * The internal rep for caching ensemble subcommand lookups and spelling
104 * corrections.
105 */
106
107 typedef struct {
108 unsigned int epoch; /* Used to confirm when the data in this
109 * really structure matches up with the
110 * ensemble. */
111 Command *token; /* Reference to the command for which this
112 * structure is a cache of the resolution. */
113 Tcl_Obj *fix; /* Corrected spelling, if needed. */
114 Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash
115 * table. */
116 } EnsembleCmdRep;
117
118 static inline Tcl_Obj *
NewNsObj(Tcl_Namespace * namespacePtr)119 NewNsObj(
120 Tcl_Namespace *namespacePtr)
121 {
122 Namespace *nsPtr = (Namespace *) namespacePtr;
123
124 if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) {
125 return Tcl_NewStringObj("::", 2);
126 }
127 return Tcl_NewStringObj(nsPtr->fullName, -1);
128 }
129
130 /*
131 *----------------------------------------------------------------------
132 *
133 * TclNamespaceEnsembleCmd --
134 *
135 * Invoked to implement the "namespace ensemble" command that creates and
136 * manipulates ensembles built on top of namespaces. Handles the
137 * following syntax:
138 *
139 * namespace ensemble name ?dictionary?
140 *
141 * Results:
142 * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong.
143 *
144 * Side effects:
145 * Creates the ensemble for the namespace if one did not previously
146 * exist. Alternatively, alters the way that the ensemble's subcommand =>
147 * implementation prefix is configured.
148 *
149 *----------------------------------------------------------------------
150 */
151
152 int
TclNamespaceEnsembleCmd(TCL_UNUSED (ClientData),Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])153 TclNamespaceEnsembleCmd(
154 TCL_UNUSED(ClientData),
155 Tcl_Interp *interp,
156 int objc,
157 Tcl_Obj *const objv[])
158 {
159 Tcl_Namespace *namespacePtr;
160 Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr,
161 *foundNsPtr, *altFoundNsPtr, *actualCxtPtr;
162 Tcl_Command token;
163 Tcl_DictSearch search;
164 Tcl_Obj *listObj;
165 const char *simpleName;
166 int index, done;
167
168 if (nsPtr == NULL || nsPtr->flags & NS_DEAD) {
169 if (!Tcl_InterpDeleted(interp)) {
170 Tcl_SetObjResult(interp, Tcl_NewStringObj(
171 "tried to manipulate ensemble of deleted namespace",
172 -1));
173 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
174 }
175 return TCL_ERROR;
176 }
177
178 if (objc < 2) {
179 Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
180 return TCL_ERROR;
181 }
182 if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
183 "subcommand", 0, &index) != TCL_OK) {
184 return TCL_ERROR;
185 }
186
187 switch ((enum EnsSubcmds) index) {
188 case ENS_CREATE: {
189 const char *name;
190 int len, allocatedMapFlag = 0;
191 /*
192 * Defaults
193 */
194 Tcl_Obj *subcmdObj = NULL;
195 Tcl_Obj *mapObj = NULL;
196 int permitPrefix = 1;
197 Tcl_Obj *unknownObj = NULL;
198 Tcl_Obj *paramObj = NULL;
199
200 /*
201 * Check that we've got option-value pairs... [Bug 1558654]
202 */
203
204 if (objc & 1) {
205 Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
206 return TCL_ERROR;
207 }
208 objv += 2;
209 objc -= 2;
210
211 name = nsPtr->name;
212 cxtPtr = (Namespace *) nsPtr->parentPtr;
213
214 /*
215 * Parse the option list, applying type checks as we go. Note that we
216 * are not incrementing any reference counts in the objects at this
217 * stage, so the presence of an option multiple times won't cause any
218 * memory leaks.
219 */
220
221 for (; objc>1 ; objc-=2,objv+=2) {
222 if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions,
223 "option", 0, &index) != TCL_OK) {
224 if (allocatedMapFlag) {
225 Tcl_DecrRefCount(mapObj);
226 }
227 return TCL_ERROR;
228 }
229 switch ((enum EnsCreateOpts) index) {
230 case CRT_CMD:
231 name = TclGetString(objv[1]);
232 cxtPtr = nsPtr;
233 continue;
234 case CRT_SUBCMDS:
235 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
236 if (allocatedMapFlag) {
237 Tcl_DecrRefCount(mapObj);
238 }
239 return TCL_ERROR;
240 }
241 subcmdObj = (len > 0 ? objv[1] : NULL);
242 continue;
243 case CRT_PARAM:
244 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
245 if (allocatedMapFlag) {
246 Tcl_DecrRefCount(mapObj);
247 }
248 return TCL_ERROR;
249 }
250 paramObj = (len > 0 ? objv[1] : NULL);
251 continue;
252 case CRT_MAP: {
253 Tcl_Obj *patchedDict = NULL, *subcmdWordsObj;
254
255 /*
256 * Verify that the map is sensible.
257 */
258
259 if (Tcl_DictObjFirst(interp, objv[1], &search,
260 &subcmdWordsObj, &listObj, &done) != TCL_OK) {
261 if (allocatedMapFlag) {
262 Tcl_DecrRefCount(mapObj);
263 }
264 return TCL_ERROR;
265 }
266 if (done) {
267 mapObj = NULL;
268 continue;
269 }
270 do {
271 Tcl_Obj **listv;
272 const char *cmd;
273
274 if (TclListObjGetElements(interp, listObj, &len,
275 &listv) != TCL_OK) {
276 Tcl_DictObjDone(&search);
277 if (patchedDict) {
278 Tcl_DecrRefCount(patchedDict);
279 }
280 if (allocatedMapFlag) {
281 Tcl_DecrRefCount(mapObj);
282 }
283 return TCL_ERROR;
284 }
285 if (len < 1) {
286 Tcl_SetObjResult(interp, Tcl_NewStringObj(
287 "ensemble subcommand implementations "
288 "must be non-empty lists", -1));
289 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
290 "EMPTY_TARGET", NULL);
291 Tcl_DictObjDone(&search);
292 if (patchedDict) {
293 Tcl_DecrRefCount(patchedDict);
294 }
295 if (allocatedMapFlag) {
296 Tcl_DecrRefCount(mapObj);
297 }
298 return TCL_ERROR;
299 }
300 cmd = TclGetString(listv[0]);
301 if (!(cmd[0] == ':' && cmd[1] == ':')) {
302 Tcl_Obj *newList = Tcl_NewListObj(len, listv);
303 Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace *) nsPtr);
304
305 if (nsPtr->parentPtr) {
306 Tcl_AppendStringsToObj(newCmd, "::", NULL);
307 }
308 Tcl_AppendObjToObj(newCmd, listv[0]);
309 Tcl_ListObjReplace(NULL, newList, 0, 1, 1, &newCmd);
310 if (patchedDict == NULL) {
311 patchedDict = Tcl_DuplicateObj(objv[1]);
312 }
313 Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
314 newList);
315 }
316 Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
317 &done);
318 } while (!done);
319
320 if (allocatedMapFlag) {
321 Tcl_DecrRefCount(mapObj);
322 }
323 mapObj = (patchedDict ? patchedDict : objv[1]);
324 if (patchedDict) {
325 allocatedMapFlag = 1;
326 }
327 continue;
328 }
329 case CRT_PREFIX:
330 if (Tcl_GetBooleanFromObj(interp, objv[1],
331 &permitPrefix) != TCL_OK) {
332 if (allocatedMapFlag) {
333 Tcl_DecrRefCount(mapObj);
334 }
335 return TCL_ERROR;
336 }
337 continue;
338 case CRT_UNKNOWN:
339 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
340 if (allocatedMapFlag) {
341 Tcl_DecrRefCount(mapObj);
342 }
343 return TCL_ERROR;
344 }
345 unknownObj = (len > 0 ? objv[1] : NULL);
346 continue;
347 }
348 }
349
350 TclGetNamespaceForQualName(interp, name, cxtPtr,
351 TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr,
352 &actualCxtPtr, &simpleName);
353
354 /*
355 * Create the ensemble. Note that this might delete another ensemble
356 * linked to the same namespace, so we must be careful. However, we
357 * should be OK because we only link the namespace into the list once
358 * we've created it (and after any deletions have occurred.)
359 */
360
361 token = TclCreateEnsembleInNs(interp, simpleName,
362 (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr,
363 (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0));
364 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
365 Tcl_SetEnsembleMappingDict(interp, token, mapObj);
366 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
367 Tcl_SetEnsembleParameterList(interp, token, paramObj);
368
369 /*
370 * Tricky! Must ensure that the result is not shared (command delete
371 * traces could have corrupted the pristine object that we started
372 * with). [Snit test rename-1.5]
373 */
374
375 Tcl_ResetResult(interp);
376 Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp));
377 return TCL_OK;
378 }
379
380 case ENS_EXISTS:
381 if (objc != 3) {
382 Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
383 return TCL_ERROR;
384 }
385 Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
386 Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
387 return TCL_OK;
388
389 case ENS_CONFIG:
390 if (objc < 3 || (objc != 4 && !(objc & 1))) {
391 Tcl_WrongNumArgs(interp, 2, objv,
392 "cmdname ?-option value ...? ?arg ...?");
393 return TCL_ERROR;
394 }
395 token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
396 if (token == NULL) {
397 return TCL_ERROR;
398 }
399
400 if (objc == 4) {
401 Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */
402
403 if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
404 "option", 0, &index) != TCL_OK) {
405 return TCL_ERROR;
406 }
407 switch ((enum EnsConfigOpts) index) {
408 case CONF_SUBCMDS:
409 Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj);
410 if (resultObj != NULL) {
411 Tcl_SetObjResult(interp, resultObj);
412 }
413 break;
414 case CONF_PARAM:
415 Tcl_GetEnsembleParameterList(NULL, token, &resultObj);
416 if (resultObj != NULL) {
417 Tcl_SetObjResult(interp, resultObj);
418 }
419 break;
420 case CONF_MAP:
421 Tcl_GetEnsembleMappingDict(NULL, token, &resultObj);
422 if (resultObj != NULL) {
423 Tcl_SetObjResult(interp, resultObj);
424 }
425 break;
426 case CONF_NAMESPACE:
427 namespacePtr = NULL; /* silence gcc 4 warning */
428 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
429 Tcl_SetObjResult(interp, NewNsObj(namespacePtr));
430 break;
431 case CONF_PREFIX: {
432 int flags = 0; /* silence gcc 4 warning */
433
434 Tcl_GetEnsembleFlags(NULL, token, &flags);
435 Tcl_SetObjResult(interp,
436 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
437 break;
438 }
439 case CONF_UNKNOWN:
440 Tcl_GetEnsembleUnknownHandler(NULL, token, &resultObj);
441 if (resultObj != NULL) {
442 Tcl_SetObjResult(interp, resultObj);
443 }
444 break;
445 }
446 } else if (objc == 3) {
447 /*
448 * Produce list of all information.
449 */
450
451 Tcl_Obj *resultObj, *tmpObj = NULL; /* silence gcc 4 warning */
452 int flags = 0; /* silence gcc 4 warning */
453
454 TclNewObj(resultObj);
455
456 /* -map option */
457 Tcl_ListObjAppendElement(NULL, resultObj,
458 Tcl_NewStringObj(ensembleConfigOptions[CONF_MAP], -1));
459 Tcl_GetEnsembleMappingDict(NULL, token, &tmpObj);
460 Tcl_ListObjAppendElement(NULL, resultObj,
461 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
462
463 /* -namespace option */
464 Tcl_ListObjAppendElement(NULL, resultObj,
465 Tcl_NewStringObj(ensembleConfigOptions[CONF_NAMESPACE],
466 -1));
467 namespacePtr = NULL; /* silence gcc 4 warning */
468 Tcl_GetEnsembleNamespace(NULL, token, &namespacePtr);
469 Tcl_ListObjAppendElement(NULL, resultObj, NewNsObj(namespacePtr));
470
471 /* -parameters option */
472 Tcl_ListObjAppendElement(NULL, resultObj,
473 Tcl_NewStringObj(ensembleConfigOptions[CONF_PARAM], -1));
474 Tcl_GetEnsembleParameterList(NULL, token, &tmpObj);
475 Tcl_ListObjAppendElement(NULL, resultObj,
476 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
477
478 /* -prefix option */
479 Tcl_ListObjAppendElement(NULL, resultObj,
480 Tcl_NewStringObj(ensembleConfigOptions[CONF_PREFIX], -1));
481 Tcl_GetEnsembleFlags(NULL, token, &flags);
482 Tcl_ListObjAppendElement(NULL, resultObj,
483 Tcl_NewBooleanObj(flags & TCL_ENSEMBLE_PREFIX));
484
485 /* -subcommands option */
486 Tcl_ListObjAppendElement(NULL, resultObj,
487 Tcl_NewStringObj(ensembleConfigOptions[CONF_SUBCMDS],-1));
488 Tcl_GetEnsembleSubcommandList(NULL, token, &tmpObj);
489 Tcl_ListObjAppendElement(NULL, resultObj,
490 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
491
492 /* -unknown option */
493 Tcl_ListObjAppendElement(NULL, resultObj,
494 Tcl_NewStringObj(ensembleConfigOptions[CONF_UNKNOWN],-1));
495 Tcl_GetEnsembleUnknownHandler(NULL, token, &tmpObj);
496 Tcl_ListObjAppendElement(NULL, resultObj,
497 (tmpObj != NULL) ? tmpObj : Tcl_NewObj());
498
499 Tcl_SetObjResult(interp, resultObj);
500 } else {
501 int len, allocatedMapFlag = 0;
502 Tcl_Obj *subcmdObj = NULL, *mapObj = NULL, *paramObj = NULL,
503 *unknownObj = NULL; /* Defaults, silence gcc 4 warnings */
504 int permitPrefix, flags = 0; /* silence gcc 4 warning */
505
506 Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj);
507 Tcl_GetEnsembleMappingDict(NULL, token, &mapObj);
508 Tcl_GetEnsembleParameterList(NULL, token, ¶mObj);
509 Tcl_GetEnsembleUnknownHandler(NULL, token, &unknownObj);
510 Tcl_GetEnsembleFlags(NULL, token, &flags);
511 permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
512
513 objv += 3;
514 objc -= 3;
515
516 /*
517 * Parse the option list, applying type checks as we go. Note that
518 * we are not incrementing any reference counts in the objects at
519 * this stage, so the presence of an option multiple times won't
520 * cause any memory leaks.
521 */
522
523 for (; objc>0 ; objc-=2,objv+=2) {
524 if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions,
525 "option", 0, &index) != TCL_OK) {
526 freeMapAndError:
527 if (allocatedMapFlag) {
528 Tcl_DecrRefCount(mapObj);
529 }
530 return TCL_ERROR;
531 }
532 switch ((enum EnsConfigOpts) index) {
533 case CONF_SUBCMDS:
534 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
535 goto freeMapAndError;
536 }
537 subcmdObj = (len > 0 ? objv[1] : NULL);
538 continue;
539 case CONF_PARAM:
540 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
541 goto freeMapAndError;
542 }
543 paramObj = (len > 0 ? objv[1] : NULL);
544 continue;
545 case CONF_MAP: {
546 Tcl_Obj *patchedDict = NULL, *subcmdWordsObj, **listv;
547 const char *cmd;
548
549 /*
550 * Verify that the map is sensible.
551 */
552
553 if (Tcl_DictObjFirst(interp, objv[1], &search,
554 &subcmdWordsObj, &listObj, &done) != TCL_OK) {
555 goto freeMapAndError;
556 }
557 if (done) {
558 mapObj = NULL;
559 continue;
560 }
561 do {
562 if (TclListObjGetElements(interp, listObj, &len,
563 &listv) != TCL_OK) {
564 Tcl_DictObjDone(&search);
565 if (patchedDict) {
566 Tcl_DecrRefCount(patchedDict);
567 }
568 goto freeMapAndError;
569 }
570 if (len < 1) {
571 Tcl_SetObjResult(interp, Tcl_NewStringObj(
572 "ensemble subcommand implementations "
573 "must be non-empty lists", -1));
574 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
575 "EMPTY_TARGET", NULL);
576 Tcl_DictObjDone(&search);
577 if (patchedDict) {
578 Tcl_DecrRefCount(patchedDict);
579 }
580 goto freeMapAndError;
581 }
582 cmd = TclGetString(listv[0]);
583 if (!(cmd[0] == ':' && cmd[1] == ':')) {
584 Tcl_Obj *newList = Tcl_DuplicateObj(listObj);
585 Tcl_Obj *newCmd = NewNsObj((Tcl_Namespace*)nsPtr);
586
587 if (nsPtr->parentPtr) {
588 Tcl_AppendStringsToObj(newCmd, "::", NULL);
589 }
590 Tcl_AppendObjToObj(newCmd, listv[0]);
591 Tcl_ListObjReplace(NULL, newList, 0, 1, 1,
592 &newCmd);
593 if (patchedDict == NULL) {
594 patchedDict = Tcl_DuplicateObj(objv[1]);
595 }
596 Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj,
597 newList);
598 }
599 Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj,
600 &done);
601 } while (!done);
602 if (allocatedMapFlag) {
603 Tcl_DecrRefCount(mapObj);
604 }
605 mapObj = (patchedDict ? patchedDict : objv[1]);
606 if (patchedDict) {
607 allocatedMapFlag = 1;
608 }
609 continue;
610 }
611 case CONF_NAMESPACE:
612 Tcl_SetObjResult(interp, Tcl_NewStringObj(
613 "option -namespace is read-only", -1));
614 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "READ_ONLY",
615 NULL);
616 goto freeMapAndError;
617 case CONF_PREFIX:
618 if (Tcl_GetBooleanFromObj(interp, objv[1],
619 &permitPrefix) != TCL_OK) {
620 goto freeMapAndError;
621 }
622 continue;
623 case CONF_UNKNOWN:
624 if (TclListObjLength(interp, objv[1], &len) != TCL_OK) {
625 goto freeMapAndError;
626 }
627 unknownObj = (len > 0 ? objv[1] : NULL);
628 continue;
629 }
630 }
631
632 /*
633 * Update the namespace now that we've finished the parsing stage.
634 */
635
636 flags = (permitPrefix ? flags|TCL_ENSEMBLE_PREFIX
637 : flags&~TCL_ENSEMBLE_PREFIX);
638 Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj);
639 Tcl_SetEnsembleMappingDict(interp, token, mapObj);
640 Tcl_SetEnsembleParameterList(interp, token, paramObj);
641 Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj);
642 Tcl_SetEnsembleFlags(interp, token, flags);
643 }
644 return TCL_OK;
645
646 default:
647 Tcl_Panic("unexpected ensemble command");
648 }
649 return TCL_OK;
650 }
651
652 /*
653 *----------------------------------------------------------------------
654 *
655 * TclCreateEnsembleInNs --
656 *
657 * Like Tcl_CreateEnsemble, but additionally accepts as an argument the
658 * name of the namespace to create the command in.
659 *
660 *----------------------------------------------------------------------
661 */
662
663 Tcl_Command
TclCreateEnsembleInNs(Tcl_Interp * interp,const char * name,Tcl_Namespace * nameNsPtr,Tcl_Namespace * ensembleNsPtr,int flags)664 TclCreateEnsembleInNs(
665 Tcl_Interp *interp,
666 const char *name, /* Simple name of command to create (no
667 * namespace components). */
668 Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command
669 * in. */
670 Tcl_Namespace *ensembleNsPtr,
671 /* Name of the namespace for the ensemble. */
672 int flags)
673 {
674 Namespace *nsPtr = (Namespace *) ensembleNsPtr;
675 EnsembleConfig *ensemblePtr;
676 Tcl_Command token;
677
678 ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig));
679 token = TclNRCreateCommandInNs(interp, name,
680 (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd,
681 NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig);
682 if (token == NULL) {
683 ckfree(ensemblePtr);
684 return NULL;
685 }
686
687 ensemblePtr->nsPtr = nsPtr;
688 ensemblePtr->epoch = 0;
689 Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS);
690 ensemblePtr->subcommandArrayPtr = NULL;
691 ensemblePtr->subcmdList = NULL;
692 ensemblePtr->subcommandDict = NULL;
693 ensemblePtr->flags = flags;
694 ensemblePtr->numParameters = 0;
695 ensemblePtr->parameterList = NULL;
696 ensemblePtr->unknownHandler = NULL;
697 ensemblePtr->token = token;
698 ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles;
699 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr;
700
701 /*
702 * Trigger an eventual recomputation of the ensemble command set. Note
703 * that this is slightly tricky, as it means that we are not actually
704 * counting the number of namespace export actions, but it is the simplest
705 * way to go!
706 */
707
708 nsPtr->exportLookupEpoch++;
709
710 if (flags & ENSEMBLE_COMPILE) {
711 ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble;
712 }
713
714 return ensemblePtr->token;
715 }
716
717 /*
718 *----------------------------------------------------------------------
719 *
720 * Tcl_CreateEnsemble
721 *
722 * Create a simple ensemble attached to the given namespace. Deprecated
723 * (internally) by TclCreateEnsembleInNs.
724 *
725 * Value
726 *
727 * The token for the command created.
728 *
729 * Effect
730 * The ensemble is created and marked for compilation.
731 *
732 *
733 *----------------------------------------------------------------------
734 */
735
736 Tcl_Command
Tcl_CreateEnsemble(Tcl_Interp * interp,const char * name,Tcl_Namespace * namespacePtr,int flags)737 Tcl_CreateEnsemble(
738 Tcl_Interp *interp,
739 const char *name,
740 Tcl_Namespace *namespacePtr,
741 int flags)
742 {
743 Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr,
744 *actualNsPtr;
745 const char * simpleName;
746
747 if (nsPtr == NULL) {
748 nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
749 }
750
751 TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN,
752 &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName);
753 return TclCreateEnsembleInNs(interp, simpleName,
754 (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags);
755 }
756
757 /*
758 *----------------------------------------------------------------------
759 *
760 * Tcl_SetEnsembleSubcommandList --
761 *
762 * Set the subcommand list for a particular ensemble.
763 *
764 * Results:
765 * Tcl result code (error if command token does not indicate an ensemble
766 * or the subcommand list - if non-NULL - is not a list).
767 *
768 * Side effects:
769 * The ensemble is updated and marked for recompilation.
770 *
771 *----------------------------------------------------------------------
772 */
773
774 int
Tcl_SetEnsembleSubcommandList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * subcmdList)775 Tcl_SetEnsembleSubcommandList(
776 Tcl_Interp *interp,
777 Tcl_Command token,
778 Tcl_Obj *subcmdList)
779 {
780 Command *cmdPtr = (Command *) token;
781 EnsembleConfig *ensemblePtr;
782 Tcl_Obj *oldList;
783
784 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
785 Tcl_SetObjResult(interp, Tcl_NewStringObj(
786 "command is not an ensemble", -1));
787 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
788 return TCL_ERROR;
789 }
790 if (subcmdList != NULL) {
791 int length;
792
793 if (TclListObjLength(interp, subcmdList, &length) != TCL_OK) {
794 return TCL_ERROR;
795 }
796 if (length < 1) {
797 subcmdList = NULL;
798 }
799 }
800
801 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
802 oldList = ensemblePtr->subcmdList;
803 ensemblePtr->subcmdList = subcmdList;
804 if (subcmdList != NULL) {
805 Tcl_IncrRefCount(subcmdList);
806 }
807 if (oldList != NULL) {
808 TclDecrRefCount(oldList);
809 }
810
811 /*
812 * Trigger an eventual recomputation of the ensemble command set. Note
813 * that this is slightly tricky, as it means that we are not actually
814 * counting the number of namespace export actions, but it is the simplest
815 * way to go!
816 */
817
818 ensemblePtr->nsPtr->exportLookupEpoch++;
819
820 /*
821 * Special hack to make compiling of [info exists] work when the
822 * dictionary is modified.
823 */
824
825 if (cmdPtr->compileProc != NULL) {
826 ((Interp *) interp)->compileEpoch++;
827 }
828
829 return TCL_OK;
830 }
831
832 /*
833 *----------------------------------------------------------------------
834 *
835 * Tcl_SetEnsembleParameterList --
836 *
837 * Set the parameter list for a particular ensemble.
838 *
839 * Results:
840 * Tcl result code (error if command token does not indicate an ensemble
841 * or the parameter list - if non-NULL - is not a list).
842 *
843 * Side effects:
844 * The ensemble is updated and marked for recompilation.
845 *
846 *----------------------------------------------------------------------
847 */
848
849 int
Tcl_SetEnsembleParameterList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * paramList)850 Tcl_SetEnsembleParameterList(
851 Tcl_Interp *interp,
852 Tcl_Command token,
853 Tcl_Obj *paramList)
854 {
855 Command *cmdPtr = (Command *) token;
856 EnsembleConfig *ensemblePtr;
857 Tcl_Obj *oldList;
858 int length;
859
860 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
861 Tcl_SetObjResult(interp, Tcl_NewStringObj(
862 "command is not an ensemble", -1));
863 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
864 return TCL_ERROR;
865 }
866 if (paramList == NULL) {
867 length = 0;
868 } else {
869 if (TclListObjLength(interp, paramList, &length) != TCL_OK) {
870 return TCL_ERROR;
871 }
872 if (length < 1) {
873 paramList = NULL;
874 }
875 }
876
877 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
878 oldList = ensemblePtr->parameterList;
879 ensemblePtr->parameterList = paramList;
880 if (paramList != NULL) {
881 Tcl_IncrRefCount(paramList);
882 }
883 if (oldList != NULL) {
884 TclDecrRefCount(oldList);
885 }
886 ensemblePtr->numParameters = length;
887
888 /*
889 * Trigger an eventual recomputation of the ensemble command set. Note
890 * that this is slightly tricky, as it means that we are not actually
891 * counting the number of namespace export actions, but it is the simplest
892 * way to go!
893 */
894
895 ensemblePtr->nsPtr->exportLookupEpoch++;
896
897 /*
898 * Special hack to make compiling of [info exists] work when the
899 * dictionary is modified.
900 */
901
902 if (cmdPtr->compileProc != NULL) {
903 ((Interp *) interp)->compileEpoch++;
904 }
905
906 return TCL_OK;
907 }
908
909 /*
910 *----------------------------------------------------------------------
911 *
912 * Tcl_SetEnsembleMappingDict --
913 *
914 * Set the mapping dictionary for a particular ensemble.
915 *
916 * Results:
917 * Tcl result code (error if command token does not indicate an ensemble
918 * or the mapping - if non-NULL - is not a dict).
919 *
920 * Side effects:
921 * The ensemble is updated and marked for recompilation.
922 *
923 *----------------------------------------------------------------------
924 */
925
926 int
Tcl_SetEnsembleMappingDict(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * mapDict)927 Tcl_SetEnsembleMappingDict(
928 Tcl_Interp *interp,
929 Tcl_Command token,
930 Tcl_Obj *mapDict)
931 {
932 Command *cmdPtr = (Command *) token;
933 EnsembleConfig *ensemblePtr;
934 Tcl_Obj *oldDict;
935
936 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
937 Tcl_SetObjResult(interp, Tcl_NewStringObj(
938 "command is not an ensemble", -1));
939 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
940 return TCL_ERROR;
941 }
942 if (mapDict != NULL) {
943 int size, done;
944 Tcl_DictSearch search;
945 Tcl_Obj *valuePtr;
946
947 if (Tcl_DictObjSize(interp, mapDict, &size) != TCL_OK) {
948 return TCL_ERROR;
949 }
950
951 for (Tcl_DictObjFirst(NULL, mapDict, &search, NULL, &valuePtr, &done);
952 !done; Tcl_DictObjNext(&search, NULL, &valuePtr, &done)) {
953 Tcl_Obj *cmdObjPtr;
954 const char *bytes;
955
956 if (Tcl_ListObjIndex(interp, valuePtr, 0, &cmdObjPtr) != TCL_OK) {
957 Tcl_DictObjDone(&search);
958 return TCL_ERROR;
959 }
960 bytes = TclGetString(cmdObjPtr);
961 if (bytes[0] != ':' || bytes[1] != ':') {
962 Tcl_SetObjResult(interp, Tcl_NewStringObj(
963 "ensemble target is not a fully-qualified command",
964 -1));
965 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE",
966 "UNQUALIFIED_TARGET", NULL);
967 Tcl_DictObjDone(&search);
968 return TCL_ERROR;
969 }
970 }
971
972 if (size < 1) {
973 mapDict = NULL;
974 }
975 }
976
977 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
978 oldDict = ensemblePtr->subcommandDict;
979 ensemblePtr->subcommandDict = mapDict;
980 if (mapDict != NULL) {
981 Tcl_IncrRefCount(mapDict);
982 }
983 if (oldDict != NULL) {
984 TclDecrRefCount(oldDict);
985 }
986
987 /*
988 * Trigger an eventual recomputation of the ensemble command set. Note
989 * that this is slightly tricky, as it means that we are not actually
990 * counting the number of namespace export actions, but it is the simplest
991 * way to go!
992 */
993
994 ensemblePtr->nsPtr->exportLookupEpoch++;
995
996 /*
997 * Special hack to make compiling of [info exists] work when the
998 * dictionary is modified.
999 */
1000
1001 if (cmdPtr->compileProc != NULL) {
1002 ((Interp *) interp)->compileEpoch++;
1003 }
1004
1005 return TCL_OK;
1006 }
1007
1008 /*
1009 *----------------------------------------------------------------------
1010 *
1011 * Tcl_SetEnsembleUnknownHandler --
1012 *
1013 * Set the unknown handler for a particular ensemble.
1014 *
1015 * Results:
1016 * Tcl result code (error if command token does not indicate an ensemble
1017 * or the unknown handler - if non-NULL - is not a list).
1018 *
1019 * Side effects:
1020 * The ensemble is updated and marked for recompilation.
1021 *
1022 *----------------------------------------------------------------------
1023 */
1024
1025 int
Tcl_SetEnsembleUnknownHandler(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj * unknownList)1026 Tcl_SetEnsembleUnknownHandler(
1027 Tcl_Interp *interp,
1028 Tcl_Command token,
1029 Tcl_Obj *unknownList)
1030 {
1031 Command *cmdPtr = (Command *) token;
1032 EnsembleConfig *ensemblePtr;
1033 Tcl_Obj *oldList;
1034
1035 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1036 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1037 "command is not an ensemble", -1));
1038 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1039 return TCL_ERROR;
1040 }
1041 if (unknownList != NULL) {
1042 int length;
1043
1044 if (TclListObjLength(interp, unknownList, &length) != TCL_OK) {
1045 return TCL_ERROR;
1046 }
1047 if (length < 1) {
1048 unknownList = NULL;
1049 }
1050 }
1051
1052 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1053 oldList = ensemblePtr->unknownHandler;
1054 ensemblePtr->unknownHandler = unknownList;
1055 if (unknownList != NULL) {
1056 Tcl_IncrRefCount(unknownList);
1057 }
1058 if (oldList != NULL) {
1059 TclDecrRefCount(oldList);
1060 }
1061
1062 /*
1063 * Trigger an eventual recomputation of the ensemble command set. Note
1064 * that this is slightly tricky, as it means that we are not actually
1065 * counting the number of namespace export actions, but it is the simplest
1066 * way to go!
1067 */
1068
1069 ensemblePtr->nsPtr->exportLookupEpoch++;
1070
1071 return TCL_OK;
1072 }
1073
1074 /*
1075 *----------------------------------------------------------------------
1076 *
1077 * Tcl_SetEnsembleFlags --
1078 *
1079 * Set the flags for a particular ensemble.
1080 *
1081 * Results:
1082 * Tcl result code (error if command token does not indicate an
1083 * ensemble).
1084 *
1085 * Side effects:
1086 * The ensemble is updated and marked for recompilation.
1087 *
1088 *----------------------------------------------------------------------
1089 */
1090
1091 int
Tcl_SetEnsembleFlags(Tcl_Interp * interp,Tcl_Command token,int flags)1092 Tcl_SetEnsembleFlags(
1093 Tcl_Interp *interp,
1094 Tcl_Command token,
1095 int flags)
1096 {
1097 Command *cmdPtr = (Command *) token;
1098 EnsembleConfig *ensemblePtr;
1099 int wasCompiled;
1100
1101 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1102 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1103 "command is not an ensemble", -1));
1104 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1105 return TCL_ERROR;
1106 }
1107
1108 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1109 wasCompiled = ensemblePtr->flags & ENSEMBLE_COMPILE;
1110
1111 /*
1112 * This API refuses to set the ENSEMBLE_DEAD flag...
1113 */
1114
1115 ensemblePtr->flags &= ENSEMBLE_DEAD;
1116 ensemblePtr->flags |= flags & ~ENSEMBLE_DEAD;
1117
1118 /*
1119 * Trigger an eventual recomputation of the ensemble command set. Note
1120 * that this is slightly tricky, as it means that we are not actually
1121 * counting the number of namespace export actions, but it is the simplest
1122 * way to go!
1123 */
1124
1125 ensemblePtr->nsPtr->exportLookupEpoch++;
1126
1127 /*
1128 * If the ENSEMBLE_COMPILE flag status was changed, install or remove the
1129 * compiler function and bump the interpreter's compilation epoch so that
1130 * bytecode gets regenerated.
1131 */
1132
1133 if (flags & ENSEMBLE_COMPILE) {
1134 if (!wasCompiled) {
1135 ((Command*) ensemblePtr->token)->compileProc = TclCompileEnsemble;
1136 ((Interp *) interp)->compileEpoch++;
1137 }
1138 } else {
1139 if (wasCompiled) {
1140 ((Command *) ensemblePtr->token)->compileProc = NULL;
1141 ((Interp *) interp)->compileEpoch++;
1142 }
1143 }
1144
1145 return TCL_OK;
1146 }
1147
1148 /*
1149 *----------------------------------------------------------------------
1150 *
1151 * Tcl_GetEnsembleSubcommandList --
1152 *
1153 * Get the list of subcommands associated with a particular ensemble.
1154 *
1155 * Results:
1156 * Tcl result code (error if command token does not indicate an
1157 * ensemble). The list of subcommands is returned by updating the
1158 * variable pointed to by the last parameter (NULL if this is to be
1159 * derived from the mapping dictionary or the associated namespace's
1160 * exported commands).
1161 *
1162 * Side effects:
1163 * None
1164 *
1165 *----------------------------------------------------------------------
1166 */
1167
1168 int
Tcl_GetEnsembleSubcommandList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** subcmdListPtr)1169 Tcl_GetEnsembleSubcommandList(
1170 Tcl_Interp *interp,
1171 Tcl_Command token,
1172 Tcl_Obj **subcmdListPtr)
1173 {
1174 Command *cmdPtr = (Command *) token;
1175 EnsembleConfig *ensemblePtr;
1176
1177 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1178 if (interp != NULL) {
1179 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1180 "command is not an ensemble", -1));
1181 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1182 }
1183 return TCL_ERROR;
1184 }
1185
1186 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1187 *subcmdListPtr = ensemblePtr->subcmdList;
1188 return TCL_OK;
1189 }
1190
1191 /*
1192 *----------------------------------------------------------------------
1193 *
1194 * Tcl_GetEnsembleParameterList --
1195 *
1196 * Get the list of parameters associated with a particular ensemble.
1197 *
1198 * Results:
1199 * Tcl result code (error if command token does not indicate an
1200 * ensemble). The list of parameters is returned by updating the
1201 * variable pointed to by the last parameter (NULL if there are
1202 * no parameters).
1203 *
1204 * Side effects:
1205 * None
1206 *
1207 *----------------------------------------------------------------------
1208 */
1209
1210 int
Tcl_GetEnsembleParameterList(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** paramListPtr)1211 Tcl_GetEnsembleParameterList(
1212 Tcl_Interp *interp,
1213 Tcl_Command token,
1214 Tcl_Obj **paramListPtr)
1215 {
1216 Command *cmdPtr = (Command *) token;
1217 EnsembleConfig *ensemblePtr;
1218
1219 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1220 if (interp != NULL) {
1221 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1222 "command is not an ensemble", -1));
1223 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1224 }
1225 return TCL_ERROR;
1226 }
1227
1228 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1229 *paramListPtr = ensemblePtr->parameterList;
1230 return TCL_OK;
1231 }
1232
1233 /*
1234 *----------------------------------------------------------------------
1235 *
1236 * Tcl_GetEnsembleMappingDict --
1237 *
1238 * Get the command mapping dictionary associated with a particular
1239 * ensemble.
1240 *
1241 * Results:
1242 * Tcl result code (error if command token does not indicate an
1243 * ensemble). The mapping dict is returned by updating the variable
1244 * pointed to by the last parameter (NULL if none is installed).
1245 *
1246 * Side effects:
1247 * None
1248 *
1249 *----------------------------------------------------------------------
1250 */
1251
1252 int
Tcl_GetEnsembleMappingDict(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** mapDictPtr)1253 Tcl_GetEnsembleMappingDict(
1254 Tcl_Interp *interp,
1255 Tcl_Command token,
1256 Tcl_Obj **mapDictPtr)
1257 {
1258 Command *cmdPtr = (Command *) token;
1259 EnsembleConfig *ensemblePtr;
1260
1261 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1262 if (interp != NULL) {
1263 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1264 "command is not an ensemble", -1));
1265 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1266 }
1267 return TCL_ERROR;
1268 }
1269
1270 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1271 *mapDictPtr = ensemblePtr->subcommandDict;
1272 return TCL_OK;
1273 }
1274
1275 /*
1276 *----------------------------------------------------------------------
1277 *
1278 * Tcl_GetEnsembleUnknownHandler --
1279 *
1280 * Get the unknown handler associated with a particular ensemble.
1281 *
1282 * Results:
1283 * Tcl result code (error if command token does not indicate an
1284 * ensemble). The unknown handler is returned by updating the variable
1285 * pointed to by the last parameter (NULL if no handler is installed).
1286 *
1287 * Side effects:
1288 * None
1289 *
1290 *----------------------------------------------------------------------
1291 */
1292
1293 int
Tcl_GetEnsembleUnknownHandler(Tcl_Interp * interp,Tcl_Command token,Tcl_Obj ** unknownListPtr)1294 Tcl_GetEnsembleUnknownHandler(
1295 Tcl_Interp *interp,
1296 Tcl_Command token,
1297 Tcl_Obj **unknownListPtr)
1298 {
1299 Command *cmdPtr = (Command *) token;
1300 EnsembleConfig *ensemblePtr;
1301
1302 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1303 if (interp != NULL) {
1304 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1305 "command is not an ensemble", -1));
1306 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1307 }
1308 return TCL_ERROR;
1309 }
1310
1311 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1312 *unknownListPtr = ensemblePtr->unknownHandler;
1313 return TCL_OK;
1314 }
1315
1316 /*
1317 *----------------------------------------------------------------------
1318 *
1319 * Tcl_GetEnsembleFlags --
1320 *
1321 * Get the flags for a particular ensemble.
1322 *
1323 * Results:
1324 * Tcl result code (error if command token does not indicate an
1325 * ensemble). The flags are returned by updating the variable pointed to
1326 * by the last parameter.
1327 *
1328 * Side effects:
1329 * None
1330 *
1331 *----------------------------------------------------------------------
1332 */
1333
1334 int
Tcl_GetEnsembleFlags(Tcl_Interp * interp,Tcl_Command token,int * flagsPtr)1335 Tcl_GetEnsembleFlags(
1336 Tcl_Interp *interp,
1337 Tcl_Command token,
1338 int *flagsPtr)
1339 {
1340 Command *cmdPtr = (Command *) token;
1341 EnsembleConfig *ensemblePtr;
1342
1343 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1344 if (interp != NULL) {
1345 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1346 "command is not an ensemble", -1));
1347 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1348 }
1349 return TCL_ERROR;
1350 }
1351
1352 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1353 *flagsPtr = ensemblePtr->flags;
1354 return TCL_OK;
1355 }
1356
1357 /*
1358 *----------------------------------------------------------------------
1359 *
1360 * Tcl_GetEnsembleNamespace --
1361 *
1362 * Get the namespace associated with a particular ensemble.
1363 *
1364 * Results:
1365 * Tcl result code (error if command token does not indicate an
1366 * ensemble). Namespace is returned by updating the variable pointed to
1367 * by the last parameter.
1368 *
1369 * Side effects:
1370 * None
1371 *
1372 *----------------------------------------------------------------------
1373 */
1374
1375 int
Tcl_GetEnsembleNamespace(Tcl_Interp * interp,Tcl_Command token,Tcl_Namespace ** namespacePtrPtr)1376 Tcl_GetEnsembleNamespace(
1377 Tcl_Interp *interp,
1378 Tcl_Command token,
1379 Tcl_Namespace **namespacePtrPtr)
1380 {
1381 Command *cmdPtr = (Command *) token;
1382 EnsembleConfig *ensemblePtr;
1383
1384 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1385 if (interp != NULL) {
1386 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1387 "command is not an ensemble", -1));
1388 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL);
1389 }
1390 return TCL_ERROR;
1391 }
1392
1393 ensemblePtr = (EnsembleConfig *)cmdPtr->objClientData;
1394 *namespacePtrPtr = (Tcl_Namespace *) ensemblePtr->nsPtr;
1395 return TCL_OK;
1396 }
1397
1398 /*
1399 *----------------------------------------------------------------------
1400 *
1401 * Tcl_FindEnsemble --
1402 *
1403 * Given a command name, get the ensemble token for it, allowing for
1404 * [namespace import]s. [Bug 1017022]
1405 *
1406 * Results:
1407 * The token for the ensemble command with the given name, or NULL if the
1408 * command either does not exist or is not an ensemble (when an error
1409 * message will be written into the interp if thats non-NULL).
1410 *
1411 * Side effects:
1412 * None
1413 *
1414 *----------------------------------------------------------------------
1415 */
1416
1417 Tcl_Command
Tcl_FindEnsemble(Tcl_Interp * interp,Tcl_Obj * cmdNameObj,int flags)1418 Tcl_FindEnsemble(
1419 Tcl_Interp *interp, /* Where to do the lookup, and where to write
1420 * the errors if TCL_LEAVE_ERR_MSG is set in
1421 * the flags. */
1422 Tcl_Obj *cmdNameObj, /* Name of command to look up. */
1423 int flags) /* Either 0 or TCL_LEAVE_ERR_MSG; other flags
1424 * are probably not useful. */
1425 {
1426 Command *cmdPtr;
1427
1428 cmdPtr = (Command *)
1429 Tcl_FindCommand(interp, TclGetString(cmdNameObj), NULL, flags);
1430 if (cmdPtr == NULL) {
1431 return NULL;
1432 }
1433
1434 if (cmdPtr->objProc != TclEnsembleImplementationCmd) {
1435 /*
1436 * Reuse existing infrastructure for following import link chains
1437 * rather than duplicating it.
1438 */
1439
1440 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
1441
1442 if (cmdPtr == NULL
1443 || cmdPtr->objProc != TclEnsembleImplementationCmd) {
1444 if (flags & TCL_LEAVE_ERR_MSG) {
1445 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1446 "\"%s\" is not an ensemble command",
1447 TclGetString(cmdNameObj)));
1448 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENSEMBLE",
1449 TclGetString(cmdNameObj), NULL);
1450 }
1451 return NULL;
1452 }
1453 }
1454
1455 return (Tcl_Command) cmdPtr;
1456 }
1457
1458 /*
1459 *----------------------------------------------------------------------
1460 *
1461 * Tcl_IsEnsemble --
1462 *
1463 * Simple test for ensemble-hood that takes into account imported
1464 * ensemble commands as well.
1465 *
1466 * Results:
1467 * Boolean value
1468 *
1469 * Side effects:
1470 * None
1471 *
1472 *----------------------------------------------------------------------
1473 */
1474
1475 int
Tcl_IsEnsemble(Tcl_Command token)1476 Tcl_IsEnsemble(
1477 Tcl_Command token)
1478 {
1479 Command *cmdPtr = (Command *) token;
1480
1481 if (cmdPtr->objProc == TclEnsembleImplementationCmd) {
1482 return 1;
1483 }
1484 cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
1485 if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) {
1486 return 0;
1487 }
1488 return 1;
1489 }
1490
1491 /*
1492 *----------------------------------------------------------------------
1493 *
1494 * TclMakeEnsemble --
1495 *
1496 * Create an ensemble from a table of implementation commands. The
1497 * ensemble will be subject to (limited) compilation if any of the
1498 * implementation commands are compilable.
1499 *
1500 * The 'name' parameter may be a single command name or a list if
1501 * creating an ensemble subcommand (see the binary implementation).
1502 *
1503 * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
1504 * top-level ensemble commands.
1505 *
1506 * Results:
1507 * Handle for the new ensemble, or NULL on failure.
1508 *
1509 * Side effects:
1510 * May advance the bytecode compilation epoch.
1511 *
1512 *----------------------------------------------------------------------
1513 */
1514
1515 Tcl_Command
TclMakeEnsemble(Tcl_Interp * interp,const char * name,const EnsembleImplMap map[])1516 TclMakeEnsemble(
1517 Tcl_Interp *interp,
1518 const char *name, /* The ensemble name (as explained above) */
1519 const EnsembleImplMap map[]) /* The subcommands to create */
1520 {
1521 Tcl_Command ensemble;
1522 Tcl_Namespace *ns;
1523 Tcl_DString buf, hiddenBuf;
1524 const char **nameParts = NULL;
1525 const char *cmdName = NULL;
1526 int i, nameCount = 0, ensembleFlags = 0, hiddenLen;
1527
1528 /*
1529 * Construct the path for the ensemble namespace and create it.
1530 */
1531
1532 Tcl_DStringInit(&buf);
1533 Tcl_DStringInit(&hiddenBuf);
1534 TclDStringAppendLiteral(&hiddenBuf, "tcl:");
1535 Tcl_DStringAppend(&hiddenBuf, name, -1);
1536 TclDStringAppendLiteral(&hiddenBuf, ":");
1537 hiddenLen = Tcl_DStringLength(&hiddenBuf);
1538 if (name[0] == ':' && name[1] == ':') {
1539 /*
1540 * An absolute name, so use it directly.
1541 */
1542
1543 cmdName = name;
1544 Tcl_DStringAppend(&buf, name, -1);
1545 ensembleFlags = TCL_ENSEMBLE_PREFIX;
1546 } else {
1547 /*
1548 * Not an absolute name, so do munging of it. Note that this treats a
1549 * multi-word list differently to a single word.
1550 */
1551
1552 TclDStringAppendLiteral(&buf, "::tcl");
1553
1554 if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
1555 Tcl_Panic("invalid ensemble name '%s'", name);
1556 }
1557
1558 for (i = 0; i < nameCount; ++i) {
1559 TclDStringAppendLiteral(&buf, "::");
1560 Tcl_DStringAppend(&buf, nameParts[i], -1);
1561 }
1562 }
1563
1564 ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
1565 TCL_CREATE_NS_IF_UNKNOWN);
1566 if (!ns) {
1567 Tcl_Panic("unable to find or create %s namespace!",
1568 Tcl_DStringValue(&buf));
1569 }
1570
1571 /*
1572 * Create the named ensemble in the correct namespace
1573 */
1574
1575 if (cmdName == NULL) {
1576 if (nameCount == 1) {
1577 ensembleFlags = TCL_ENSEMBLE_PREFIX;
1578 cmdName = Tcl_DStringValue(&buf) + 5;
1579 } else {
1580 ns = ns->parentPtr;
1581 cmdName = nameParts[nameCount - 1];
1582 }
1583 }
1584
1585 /*
1586 * Switch on compilation always for core ensembles now that we can do
1587 * nice bytecode things with them. Do it now. Waiting until later will
1588 * just cause pointless epoch bumps.
1589 */
1590
1591 ensembleFlags |= ENSEMBLE_COMPILE;
1592 ensemble = Tcl_CreateEnsemble(interp, cmdName, ns, ensembleFlags);
1593
1594 /*
1595 * Create the ensemble mapping dictionary and the ensemble command procs.
1596 */
1597
1598 if (ensemble != NULL) {
1599 Tcl_Obj *mapDict, *fromObj, *toObj;
1600 Command *cmdPtr;
1601
1602 TclDStringAppendLiteral(&buf, "::");
1603 TclNewObj(mapDict);
1604 for (i=0 ; map[i].name != NULL ; i++) {
1605 fromObj = Tcl_NewStringObj(map[i].name, -1);
1606 TclNewStringObj(toObj, Tcl_DStringValue(&buf),
1607 Tcl_DStringLength(&buf));
1608 Tcl_AppendToObj(toObj, map[i].name, -1);
1609 Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
1610
1611 if (map[i].proc || map[i].nreProc) {
1612 /*
1613 * If the command is unsafe, hide it when we're in a safe
1614 * interpreter. The code to do this is really hokey! It also
1615 * doesn't work properly yet; this function is always
1616 * currently called before the safe-interp flag is set so the
1617 * Tcl_IsSafe check fails.
1618 */
1619
1620 if (map[i].unsafe && Tcl_IsSafe(interp)) {
1621 cmdPtr = (Command *)
1622 Tcl_NRCreateCommand(interp, "___tmp", map[i].proc,
1623 map[i].nreProc, map[i].clientData, NULL);
1624 Tcl_DStringSetLength(&hiddenBuf, hiddenLen);
1625 if (Tcl_HideCommand(interp, "___tmp",
1626 Tcl_DStringAppend(&hiddenBuf, map[i].name, -1))) {
1627 Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
1628 }
1629 } else {
1630 /*
1631 * Not hidden, so just create it. Yay!
1632 */
1633
1634 cmdPtr = (Command *)
1635 Tcl_NRCreateCommand(interp, TclGetString(toObj),
1636 map[i].proc, map[i].nreProc, map[i].clientData,
1637 NULL);
1638 }
1639 cmdPtr->compileProc = map[i].compileProc;
1640 }
1641 }
1642 Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
1643 }
1644
1645 Tcl_DStringFree(&buf);
1646 Tcl_DStringFree(&hiddenBuf);
1647 if (nameParts != NULL) {
1648 ckfree(nameParts);
1649 }
1650 return ensemble;
1651 }
1652
1653 /*
1654 *----------------------------------------------------------------------
1655 *
1656 * TclEnsembleImplementationCmd --
1657 *
1658 * Implements an ensemble of commands (being those exported by a
1659 * namespace other than the global namespace) as a command with the same
1660 * (short) name as the namespace in the parent namespace.
1661 *
1662 * Results:
1663 * A standard Tcl result code. Will be TCL_ERROR if the command is not an
1664 * unambiguous prefix of any command exported by the ensemble's
1665 * namespace.
1666 *
1667 * Side effects:
1668 * Depends on the command within the namespace that gets executed. If the
1669 * ensemble itself returns TCL_ERROR, a descriptive error message will be
1670 * placed in the interpreter's result.
1671 *
1672 *----------------------------------------------------------------------
1673 */
1674
1675 int
TclEnsembleImplementationCmd(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1676 TclEnsembleImplementationCmd(
1677 ClientData clientData,
1678 Tcl_Interp *interp,
1679 int objc,
1680 Tcl_Obj *const objv[])
1681 {
1682 return Tcl_NRCallObjProc(interp, NsEnsembleImplementationCmdNR,
1683 clientData, objc, objv);
1684 }
1685
1686 static int
NsEnsembleImplementationCmdNR(ClientData clientData,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])1687 NsEnsembleImplementationCmdNR(
1688 ClientData clientData,
1689 Tcl_Interp *interp,
1690 int objc,
1691 Tcl_Obj *const objv[])
1692 {
1693 EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
1694 /* The ensemble itself. */
1695 Tcl_Obj *prefixObj; /* An object containing the prefix words of
1696 * the command that implements the
1697 * subcommand. */
1698 Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully
1699 * specified but not yet cached command
1700 * names. */
1701 int reparseCount = 0; /* Number of reparses. */
1702 Tcl_Obj *errorObj; /* Used for building error messages. */
1703 Tcl_Obj *subObj;
1704 int subIdx;
1705
1706 /*
1707 * Must recheck objc, since numParameters might have changed. Cf. test
1708 * namespace-53.9.
1709 */
1710
1711 restartEnsembleParse:
1712 subIdx = 1 + ensemblePtr->numParameters;
1713 if (objc < subIdx + 1) {
1714 /*
1715 * We don't have a subcommand argument. Make error message.
1716 */
1717
1718 Tcl_DString buf; /* Message being built */
1719
1720 Tcl_DStringInit(&buf);
1721 if (ensemblePtr->parameterList) {
1722 Tcl_DStringAppend(&buf,
1723 TclGetString(ensemblePtr->parameterList), -1);
1724 TclDStringAppendLiteral(&buf, " ");
1725 }
1726 TclDStringAppendLiteral(&buf, "subcommand ?arg ...?");
1727 Tcl_WrongNumArgs(interp, 1, objv, Tcl_DStringValue(&buf));
1728 Tcl_DStringFree(&buf);
1729
1730 return TCL_ERROR;
1731 }
1732
1733 if (ensemblePtr->nsPtr->flags & NS_DEAD) {
1734 /*
1735 * Don't know how we got here, but make things give up quickly.
1736 */
1737
1738 if (!Tcl_InterpDeleted(interp)) {
1739 Tcl_SetObjResult(interp, Tcl_NewStringObj(
1740 "ensemble activated for deleted namespace", -1));
1741 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "DEAD", NULL);
1742 }
1743 return TCL_ERROR;
1744 }
1745
1746 /*
1747 * Determine if the table of subcommands is right. If so, we can just look
1748 * up in there and go straight to dispatch.
1749 */
1750
1751 subObj = objv[subIdx];
1752
1753 if (ensemblePtr->epoch == ensemblePtr->nsPtr->exportLookupEpoch) {
1754 /*
1755 * Table of subcommands is still valid; therefore there might be a
1756 * valid cache of discovered information which we can reuse. Do the
1757 * check here, and if we're still valid, we can jump straight to the
1758 * part where we do the invocation of the subcommand.
1759 */
1760 EnsembleCmdRep *ensembleCmd;
1761
1762 ECRGetIntRep(subObj, ensembleCmd);
1763 if (ensembleCmd) {
1764 if (ensembleCmd->epoch == ensemblePtr->epoch &&
1765 ensembleCmd->token == (Command *)ensemblePtr->token) {
1766 prefixObj = (Tcl_Obj *)Tcl_GetHashValue(ensembleCmd->hPtr);
1767 Tcl_IncrRefCount(prefixObj);
1768 if (ensembleCmd->fix) {
1769 TclSpellFix(interp, objv, objc, subIdx, subObj, ensembleCmd->fix);
1770 }
1771 goto runResultingSubcommand;
1772 }
1773 }
1774 } else {
1775 BuildEnsembleConfig(ensemblePtr);
1776 ensemblePtr->epoch = ensemblePtr->nsPtr->exportLookupEpoch;
1777 }
1778
1779 /*
1780 * Look in the hashtable for the subcommand name; this is the fastest way
1781 * of all if there is no cache in operation.
1782 */
1783
1784 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable,
1785 TclGetString(subObj));
1786 if (hPtr != NULL) {
1787
1788 /*
1789 * Cache for later in the subcommand object.
1790 */
1791
1792 MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, NULL);
1793 } else if (!(ensemblePtr->flags & TCL_ENSEMBLE_PREFIX)) {
1794 /*
1795 * Could not map, no prefixing, go to unknown/error handling.
1796 */
1797
1798 goto unknownOrAmbiguousSubcommand;
1799 } else {
1800 /*
1801 * If we've not already confirmed the command with the hash as part of
1802 * building our export table, we need to scan the sorted array for
1803 * matches.
1804 */
1805
1806 const char *subcmdName; /* Name of the subcommand, or unique prefix of
1807 * it (will be an error for a non-unique
1808 * prefix). */
1809 char *fullName = NULL; /* Full name of the subcommand. */
1810 int stringLength, i;
1811 int tableLength = ensemblePtr->subcommandTable.numEntries;
1812 Tcl_Obj *fix;
1813
1814 subcmdName = TclGetStringFromObj(subObj, &stringLength);
1815 for (i=0 ; i<tableLength ; i++) {
1816 int cmp = strncmp(subcmdName,
1817 ensemblePtr->subcommandArrayPtr[i],
1818 stringLength);
1819
1820 if (cmp == 0) {
1821 if (fullName != NULL) {
1822 /*
1823 * Since there's never the exact-match case to worry about
1824 * (hash search filters this), getting here indicates that
1825 * our subcommand is an ambiguous prefix of (at least) two
1826 * exported subcommands, which is an error case.
1827 */
1828
1829 goto unknownOrAmbiguousSubcommand;
1830 }
1831 fullName = ensemblePtr->subcommandArrayPtr[i];
1832 } else if (cmp < 0) {
1833 /*
1834 * Because we are searching a sorted table, we can now stop
1835 * searching because we have gone past anything that could
1836 * possibly match.
1837 */
1838
1839 break;
1840 }
1841 }
1842 if (fullName == NULL) {
1843 /*
1844 * The subcommand is not a prefix of anything, so bail out!
1845 */
1846
1847 goto unknownOrAmbiguousSubcommand;
1848 }
1849 hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName);
1850 if (hPtr == NULL) {
1851 Tcl_Panic("full name %s not found in supposedly synchronized hash",
1852 fullName);
1853 }
1854
1855 /*
1856 * Record the spelling correction for usage message.
1857 */
1858
1859 fix = Tcl_NewStringObj(fullName, -1);
1860
1861 /*
1862 * Cache for later in the subcommand object.
1863 */
1864
1865 MakeCachedEnsembleCommand(subObj, ensemblePtr, hPtr, fix);
1866 TclSpellFix(interp, objv, objc, subIdx, subObj, fix);
1867 }
1868
1869 prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
1870 Tcl_IncrRefCount(prefixObj);
1871 runResultingSubcommand:
1872
1873 /*
1874 * Do the real work of execution of the subcommand by building an array of
1875 * objects (note that this is potentially not the same length as the
1876 * number of arguments to this ensemble command), populating it and then
1877 * feeding it back through the main command-lookup engine. In theory, we
1878 * could look up the command in the namespace ourselves, as we already
1879 * have the namespace in which it is guaranteed to exist,
1880 *
1881 * ((Q: That's not true if the -map option is used, is it?))
1882 *
1883 * but we don't do that (the cacheing of the command object used should
1884 * help with that.)
1885 */
1886
1887 {
1888 Tcl_Obj *copyPtr; /* The actual list of words to dispatch to.
1889 * Will be freed by the dispatch engine. */
1890 Tcl_Obj **copyObjv;
1891 int copyObjc, prefixObjc;
1892
1893 Tcl_ListObjLength(NULL, prefixObj, &prefixObjc);
1894
1895 if (objc == 2) {
1896 copyPtr = TclListObjCopy(NULL, prefixObj);
1897 } else {
1898 copyPtr = Tcl_NewListObj(objc - 2 + prefixObjc, NULL);
1899 Tcl_ListObjAppendList(NULL, copyPtr, prefixObj);
1900 Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
1901 ensemblePtr->numParameters, objv + 1);
1902 Tcl_ListObjReplace(NULL, copyPtr, LIST_MAX, 0,
1903 objc - 2 - ensemblePtr->numParameters,
1904 objv + 2 + ensemblePtr->numParameters);
1905 }
1906 Tcl_IncrRefCount(copyPtr);
1907 TclNRAddCallback(interp, TclNRReleaseValues, copyPtr, NULL, NULL, NULL);
1908 TclDecrRefCount(prefixObj);
1909
1910 /*
1911 * Record what arguments the script sent in so that things like
1912 * Tcl_WrongNumArgs can give the correct error message. Parameters
1913 * count both as inserted and removed arguments.
1914 */
1915
1916 if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters,
1917 prefixObjc + ensemblePtr->numParameters, objv)) {
1918 TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL,
1919 NULL);
1920 }
1921
1922 /*
1923 * Hand off to the target command.
1924 */
1925
1926 TclSkipTailcall(interp);
1927 Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv);
1928 ((Interp *)interp)->lookupNsPtr = ensemblePtr->nsPtr;
1929 return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL);
1930 }
1931
1932 unknownOrAmbiguousSubcommand:
1933 /*
1934 * Have not been able to match the subcommand asked for with a real
1935 * subcommand that we export. See whether a handler has been registered
1936 * for dealing with this situation. Will only call (at most) once for any
1937 * particular ensemble invocation.
1938 */
1939
1940 if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) {
1941 switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv,
1942 &prefixObj)) {
1943 case TCL_OK:
1944 goto runResultingSubcommand;
1945 case TCL_ERROR:
1946 return TCL_ERROR;
1947 case TCL_CONTINUE:
1948 goto restartEnsembleParse;
1949 }
1950 }
1951
1952 /*
1953 * We cannot determine what subcommand to hand off to, so generate a
1954 * (standard) failure message. Note the one odd case compared with
1955 * standard ensemble-like command, which is where a namespace has no
1956 * exported commands at all...
1957 */
1958
1959 Tcl_ResetResult(interp);
1960 Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "SUBCOMMAND",
1961 TclGetString(subObj), NULL);
1962 if (ensemblePtr->subcommandTable.numEntries == 0) {
1963 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
1964 "unknown subcommand \"%s\": namespace %s does not"
1965 " export any commands", TclGetString(subObj),
1966 ensemblePtr->nsPtr->fullName));
1967 return TCL_ERROR;
1968 }
1969 errorObj = Tcl_ObjPrintf("unknown%s subcommand \"%s\": must be ",
1970 (ensemblePtr->flags & TCL_ENSEMBLE_PREFIX ? " or ambiguous" : ""),
1971 TclGetString(subObj));
1972 if (ensemblePtr->subcommandTable.numEntries == 1) {
1973 Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[0], -1);
1974 } else {
1975 int i;
1976
1977 for (i=0 ; i<ensemblePtr->subcommandTable.numEntries-1 ; i++) {
1978 Tcl_AppendToObj(errorObj, ensemblePtr->subcommandArrayPtr[i], -1);
1979 Tcl_AppendToObj(errorObj, ", ", 2);
1980 }
1981 Tcl_AppendPrintfToObj(errorObj, "or %s",
1982 ensemblePtr->subcommandArrayPtr[i]);
1983 }
1984 Tcl_SetObjResult(interp, errorObj);
1985 return TCL_ERROR;
1986 }
1987
1988 int
TclClearRootEnsemble(TCL_UNUSED (ClientData *),Tcl_Interp * interp,int result)1989 TclClearRootEnsemble(
1990 TCL_UNUSED(ClientData *),
1991 Tcl_Interp *interp,
1992 int result)
1993 {
1994 TclResetRewriteEnsemble(interp, 1);
1995 return result;
1996 }
1997
1998 /*
1999 *----------------------------------------------------------------------
2000 *
2001 * TclInitRewriteEnsemble --
2002 *
2003 * Applies a rewrite of arguments so that an ensemble subcommand will
2004 * report error messages correctly for the overall command.
2005 *
2006 * Results:
2007 * Whether this is the first rewrite applied, a value which must be
2008 * passed to TclResetRewriteEnsemble when undoing this command's
2009 * behaviour.
2010 *
2011 * Side effects:
2012 * None.
2013 *
2014 *----------------------------------------------------------------------
2015 */
2016
2017 int
TclInitRewriteEnsemble(Tcl_Interp * interp,int numRemoved,int numInserted,Tcl_Obj * const * objv)2018 TclInitRewriteEnsemble(
2019 Tcl_Interp *interp,
2020 int numRemoved,
2021 int numInserted,
2022 Tcl_Obj *const *objv)
2023 {
2024 Interp *iPtr = (Interp *) interp;
2025
2026 int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
2027
2028 if (isRootEnsemble) {
2029 iPtr->ensembleRewrite.sourceObjs = objv;
2030 iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
2031 iPtr->ensembleRewrite.numInsertedObjs = numInserted;
2032 } else {
2033 int numIns = iPtr->ensembleRewrite.numInsertedObjs;
2034
2035 if (numIns < numRemoved) {
2036 iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
2037 iPtr->ensembleRewrite.numInsertedObjs = numInserted;
2038 } else {
2039 iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
2040 }
2041 }
2042 return isRootEnsemble;
2043 }
2044
2045 /*
2046 *----------------------------------------------------------------------
2047 *
2048 * TclResetRewriteEnsemble --
2049 *
2050 * Removes any rewrites applied to support proper reporting of error
2051 * messages used in ensembles. Should be paired with
2052 * TclInitRewriteEnsemble.
2053 *
2054 * Results:
2055 * None.
2056 *
2057 * Side effects:
2058 * None.
2059 *
2060 *----------------------------------------------------------------------
2061 */
2062
2063 void
TclResetRewriteEnsemble(Tcl_Interp * interp,int isRootEnsemble)2064 TclResetRewriteEnsemble(
2065 Tcl_Interp *interp,
2066 int isRootEnsemble)
2067 {
2068 Interp *iPtr = (Interp *) interp;
2069
2070 if (isRootEnsemble) {
2071 iPtr->ensembleRewrite.sourceObjs = NULL;
2072 iPtr->ensembleRewrite.numRemovedObjs = 0;
2073 iPtr->ensembleRewrite.numInsertedObjs = 0;
2074 }
2075 }
2076
2077 /*
2078 *----------------------------------------------------------------------
2079 *
2080 * TclSpellFix --
2081 *
2082 * Record a spelling correction that needs making in the generation of
2083 * the WrongNumArgs usage message.
2084 *
2085 * Results:
2086 * None.
2087 *
2088 * Side effects:
2089 * Can create an alternative ensemble rewrite structure.
2090 *
2091 *----------------------------------------------------------------------
2092 */
2093
2094 static int
FreeER(ClientData data[],TCL_UNUSED (Tcl_Interp *),int result)2095 FreeER(
2096 ClientData data[],
2097 TCL_UNUSED(Tcl_Interp *),
2098 int result)
2099 {
2100 Tcl_Obj **tmp = (Tcl_Obj **) data[0];
2101 Tcl_Obj **store = (Tcl_Obj **) data[1];
2102
2103 ckfree(store);
2104 ckfree(tmp);
2105 return result;
2106 }
2107
2108 void
TclSpellFix(Tcl_Interp * interp,Tcl_Obj * const * objv,int objc,int badIdx,Tcl_Obj * bad,Tcl_Obj * fix)2109 TclSpellFix(
2110 Tcl_Interp *interp,
2111 Tcl_Obj *const *objv,
2112 int objc,
2113 int badIdx,
2114 Tcl_Obj *bad,
2115 Tcl_Obj *fix)
2116 {
2117 Interp *iPtr = (Interp *) interp;
2118 Tcl_Obj *const *search;
2119 Tcl_Obj **store;
2120 int idx;
2121 int size;
2122
2123 if (iPtr->ensembleRewrite.sourceObjs == NULL) {
2124 iPtr->ensembleRewrite.sourceObjs = objv;
2125 iPtr->ensembleRewrite.numRemovedObjs = 0;
2126 iPtr->ensembleRewrite.numInsertedObjs = 0;
2127 }
2128
2129 /*
2130 * Compute the valid length of the ensemble root.
2131 */
2132
2133 size = iPtr->ensembleRewrite.numRemovedObjs + objc
2134 - iPtr->ensembleRewrite.numInsertedObjs;
2135
2136 search = iPtr->ensembleRewrite.sourceObjs;
2137 if (search[0] == NULL) {
2138 /*
2139 * Awful casting abuse here!
2140 */
2141
2142 search = (Tcl_Obj *const *) search[1];
2143 }
2144
2145 if (badIdx < iPtr->ensembleRewrite.numInsertedObjs) {
2146 /*
2147 * Misspelled value was inserted. We cannot directly jump to the bad
2148 * value, but have to search.
2149 */
2150
2151 idx = 1;
2152 while (idx < size) {
2153 if (search[idx] == bad) {
2154 break;
2155 }
2156 idx++;
2157 }
2158 if (idx == size) {
2159 return;
2160 }
2161 } else {
2162 /*
2163 * Jump to the misspelled value.
2164 */
2165
2166 idx = iPtr->ensembleRewrite.numRemovedObjs + badIdx
2167 - iPtr->ensembleRewrite.numInsertedObjs;
2168
2169 /* Verify */
2170 if (search[idx] != bad) {
2171 Tcl_Panic("SpellFix: programming error");
2172 }
2173 }
2174
2175 search = iPtr->ensembleRewrite.sourceObjs;
2176 if (search[0] == NULL) {
2177 store = (Tcl_Obj **) search[2];
2178 } else {
2179 Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *));
2180
2181 store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *));
2182 memcpy(store, iPtr->ensembleRewrite.sourceObjs,
2183 size * sizeof(Tcl_Obj *));
2184
2185 /*
2186 * Awful casting abuse here! Note that the NULL in the first element
2187 * indicates that the initial objects are a raw array in the second
2188 * element and the rewritten ones are a raw array in the third.
2189 */
2190
2191 tmp[0] = NULL;
2192 tmp[1] = (Tcl_Obj *) iPtr->ensembleRewrite.sourceObjs;
2193 tmp[2] = (Tcl_Obj *) store;
2194 iPtr->ensembleRewrite.sourceObjs = (Tcl_Obj *const *) tmp;
2195
2196 TclNRAddCallback(interp, FreeER, tmp, store, NULL, NULL);
2197 }
2198
2199 store[idx] = fix;
2200 Tcl_IncrRefCount(fix);
2201 TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL);
2202 }
2203
2204 /*
2205 *----------------------------------------------------------------------
2206 *
2207 * TclFetchEnsembleRoot --
2208 *
2209 * Returns the root of ensemble rewriting, if any.
2210 * If no root exists, returns objv instead.
2211 *
2212 * Results:
2213 * None.
2214 *
2215 * Side effects:
2216 * None.
2217 *
2218 *----------------------------------------------------------------------
2219 */
2220
2221 Tcl_Obj *const *
TclFetchEnsembleRoot(Tcl_Interp * interp,Tcl_Obj * const * objv,int objc,int * objcPtr)2222 TclFetchEnsembleRoot(
2223 Tcl_Interp *interp,
2224 Tcl_Obj *const *objv,
2225 int objc,
2226 int *objcPtr)
2227 {
2228 Interp *iPtr = (Interp *) interp;
2229
2230 if (iPtr->ensembleRewrite.sourceObjs) {
2231 *objcPtr = objc + iPtr->ensembleRewrite.numRemovedObjs
2232 - iPtr->ensembleRewrite.numInsertedObjs;
2233 return iPtr->ensembleRewrite.sourceObjs;
2234 }
2235 *objcPtr = objc;
2236 return objv;
2237 }
2238
2239 /*
2240 * ----------------------------------------------------------------------
2241 *
2242 * EnsmebleUnknownCallback --
2243 *
2244 * Helper for the ensemble engine that handles the procesing of unknown
2245 * callbacks. See the user documentation of the ensemble unknown handler
2246 * for details; this function is only ever called when such a function is
2247 * defined, and is only ever called once per ensemble dispatch (i.e. if a
2248 * reparse still fails, this isn't called again).
2249 *
2250 * Results:
2251 * TCL_OK - *prefixObjPtr contains the command words to dispatch
2252 * to.
2253 * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid).
2254 * TCL_ERROR - Something went wrong! Error message in interpreter.
2255 *
2256 * Side effects:
2257 * Calls the Tcl interpreter, so arbitrary.
2258 *
2259 * ----------------------------------------------------------------------
2260 */
2261
2262 static inline int
EnsembleUnknownCallback(Tcl_Interp * interp,EnsembleConfig * ensemblePtr,int objc,Tcl_Obj * const objv[],Tcl_Obj ** prefixObjPtr)2263 EnsembleUnknownCallback(
2264 Tcl_Interp *interp,
2265 EnsembleConfig *ensemblePtr,
2266 int objc,
2267 Tcl_Obj *const objv[],
2268 Tcl_Obj **prefixObjPtr)
2269 {
2270 int paramc, i, result, prefixObjc;
2271 Tcl_Obj **paramv, *unknownCmd, *ensObj;
2272
2273 /*
2274 * Create the unknown command callback to determine what to do.
2275 */
2276
2277 unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler);
2278 TclNewObj(ensObj);
2279 Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj);
2280 Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj);
2281 for (i=1 ; i<objc ; i++) {
2282 Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]);
2283 }
2284 TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv);
2285 Tcl_IncrRefCount(unknownCmd);
2286
2287 /*
2288 * Now call the unknown handler. (We don't bother NRE-enabling this; deep
2289 * recursing through unknown handlers is horribly perverse.) Note that it
2290 * is always an error for an unknown handler to delete its ensemble; don't
2291 * do that!
2292 */
2293
2294 Tcl_Preserve(ensemblePtr);
2295 TclSkipTailcall(interp);
2296 result = Tcl_EvalObjv(interp, paramc, paramv, 0);
2297 if ((result == TCL_OK) && (ensemblePtr->flags & ENSEMBLE_DEAD)) {
2298 if (!Tcl_InterpDeleted(interp)) {
2299 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2300 "unknown subcommand handler deleted its ensemble", -1));
2301 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_DELETED",
2302 NULL);
2303 }
2304 result = TCL_ERROR;
2305 }
2306 Tcl_Release(ensemblePtr);
2307
2308 /*
2309 * If we succeeded, we should either have a list of words that form the
2310 * command to be executed, or an empty list. In the empty-list case, the
2311 * ensemble is believed to be updated so we should ask the ensemble engine
2312 * to reparse the original command.
2313 */
2314
2315 if (result == TCL_OK) {
2316 *prefixObjPtr = Tcl_GetObjResult(interp);
2317 Tcl_IncrRefCount(*prefixObjPtr);
2318 TclDecrRefCount(unknownCmd);
2319 Tcl_ResetResult(interp);
2320
2321 /*
2322 * Namespace is still there. Check if the result is a valid list. If
2323 * it is, and it is non-empty, that list is what we are using as our
2324 * replacement.
2325 */
2326
2327 if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) {
2328 TclDecrRefCount(*prefixObjPtr);
2329 Tcl_AddErrorInfo(interp, "\n while parsing result of "
2330 "ensemble unknown subcommand handler");
2331 return TCL_ERROR;
2332 }
2333 if (prefixObjc > 0) {
2334 return TCL_OK;
2335 }
2336
2337 /*
2338 * Namespace alive & empty result => reparse.
2339 */
2340
2341 TclDecrRefCount(*prefixObjPtr);
2342 return TCL_CONTINUE;
2343 }
2344
2345 /*
2346 * Oh no! An exceptional result. Convert to an error.
2347 */
2348
2349 if (!Tcl_InterpDeleted(interp)) {
2350 if (result != TCL_ERROR) {
2351 Tcl_ResetResult(interp);
2352 Tcl_SetObjResult(interp, Tcl_NewStringObj(
2353 "unknown subcommand handler returned bad code: ", -1));
2354 switch (result) {
2355 case TCL_RETURN:
2356 Tcl_AppendToObj(Tcl_GetObjResult(interp), "return", -1);
2357 break;
2358 case TCL_BREAK:
2359 Tcl_AppendToObj(Tcl_GetObjResult(interp), "break", -1);
2360 break;
2361 case TCL_CONTINUE:
2362 Tcl_AppendToObj(Tcl_GetObjResult(interp), "continue", -1);
2363 break;
2364 default:
2365 Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "%d", result);
2366 }
2367 Tcl_AddErrorInfo(interp, "\n result of "
2368 "ensemble unknown subcommand handler: ");
2369 Tcl_AppendObjToErrorInfo(interp, unknownCmd);
2370 Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "UNKNOWN_RESULT",
2371 NULL);
2372 } else {
2373 Tcl_AddErrorInfo(interp,
2374 "\n (ensemble unknown subcommand handler)");
2375 }
2376 }
2377 TclDecrRefCount(unknownCmd);
2378 return TCL_ERROR;
2379 }
2380
2381 /*
2382 *----------------------------------------------------------------------
2383 *
2384 * MakeCachedEnsembleCommand --
2385 *
2386 * Cache what we've computed so far; it's not nice to repeatedly copy
2387 * strings about. Note that to do this, we start by deleting any old
2388 * representation that there was (though if it was an out of date
2389 * ensemble rep, we can skip some of the deallocation process.)
2390 *
2391 * Results:
2392 * None
2393 *
2394 * Side effects:
2395 * Alters the internal representation of the first object parameter.
2396 *
2397 *----------------------------------------------------------------------
2398 */
2399
2400 static void
MakeCachedEnsembleCommand(Tcl_Obj * objPtr,EnsembleConfig * ensemblePtr,Tcl_HashEntry * hPtr,Tcl_Obj * fix)2401 MakeCachedEnsembleCommand(
2402 Tcl_Obj *objPtr,
2403 EnsembleConfig *ensemblePtr,
2404 Tcl_HashEntry *hPtr,
2405 Tcl_Obj *fix)
2406 {
2407 EnsembleCmdRep *ensembleCmd;
2408
2409 ECRGetIntRep(objPtr, ensembleCmd);
2410 if (ensembleCmd) {
2411 TclCleanupCommandMacro(ensembleCmd->token);
2412 if (ensembleCmd->fix) {
2413 Tcl_DecrRefCount(ensembleCmd->fix);
2414 }
2415 } else {
2416 /*
2417 * Kill the old internal rep, and replace it with a brand new one of
2418 * our own.
2419 */
2420
2421 ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
2422 ECRSetIntRep(objPtr, ensembleCmd);
2423 }
2424
2425 /*
2426 * Populate the internal rep.
2427 */
2428
2429 ensembleCmd->epoch = ensemblePtr->epoch;
2430 ensembleCmd->token = (Command *) ensemblePtr->token;
2431 ensembleCmd->token->refCount++;
2432 if (fix) {
2433 Tcl_IncrRefCount(fix);
2434 }
2435 ensembleCmd->fix = fix;
2436 ensembleCmd->hPtr = hPtr;
2437 }
2438
2439 /*
2440 *----------------------------------------------------------------------
2441 *
2442 * DeleteEnsembleConfig --
2443 *
2444 * Destroys the data structure used to represent an ensemble. This is
2445 * called when the ensemble's command is deleted (which happens
2446 * automatically if the ensemble's namespace is deleted.) Maintainers
2447 * should note that ensembles should be deleted by deleting their
2448 * commands.
2449 *
2450 * Results:
2451 * None.
2452 *
2453 * Side effects:
2454 * Memory is (eventually) deallocated.
2455 *
2456 *----------------------------------------------------------------------
2457 */
2458
2459 static void
ClearTable(EnsembleConfig * ensemblePtr)2460 ClearTable(
2461 EnsembleConfig *ensemblePtr)
2462 {
2463 Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
2464
2465 if (hash->numEntries != 0) {
2466 Tcl_HashSearch search;
2467 Tcl_HashEntry *hPtr = Tcl_FirstHashEntry(hash, &search);
2468
2469 while (hPtr != NULL) {
2470 Tcl_Obj *prefixObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
2471 Tcl_DecrRefCount(prefixObj);
2472 hPtr = Tcl_NextHashEntry(&search);
2473 }
2474 ckfree((char *) ensemblePtr->subcommandArrayPtr);
2475 }
2476 Tcl_DeleteHashTable(hash);
2477 }
2478
2479 static void
DeleteEnsembleConfig(ClientData clientData)2480 DeleteEnsembleConfig(
2481 ClientData clientData)
2482 {
2483 EnsembleConfig *ensemblePtr = (EnsembleConfig *)clientData;
2484 Namespace *nsPtr = ensemblePtr->nsPtr;
2485
2486 /*
2487 * Unlink from the ensemble chain if it has not been marked as having been
2488 * done already.
2489 */
2490
2491 if (ensemblePtr->next != ensemblePtr) {
2492 EnsembleConfig *ensPtr = (EnsembleConfig *) nsPtr->ensembles;
2493
2494 if (ensPtr == ensemblePtr) {
2495 nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next;
2496 } else {
2497 while (ensPtr != NULL) {
2498 if (ensPtr->next == ensemblePtr) {
2499 ensPtr->next = ensemblePtr->next;
2500 break;
2501 }
2502 ensPtr = ensPtr->next;
2503 }
2504 }
2505 }
2506
2507 /*
2508 * Mark the namespace as dead so code that uses Tcl_Preserve() can tell
2509 * whether disaster happened anyway.
2510 */
2511
2512 ensemblePtr->flags |= ENSEMBLE_DEAD;
2513
2514 /*
2515 * Kill the pointer-containing fields.
2516 */
2517
2518 ClearTable(ensemblePtr);
2519 if (ensemblePtr->subcmdList != NULL) {
2520 Tcl_DecrRefCount(ensemblePtr->subcmdList);
2521 }
2522 if (ensemblePtr->parameterList != NULL) {
2523 Tcl_DecrRefCount(ensemblePtr->parameterList);
2524 }
2525 if (ensemblePtr->subcommandDict != NULL) {
2526 Tcl_DecrRefCount(ensemblePtr->subcommandDict);
2527 }
2528 if (ensemblePtr->unknownHandler != NULL) {
2529 Tcl_DecrRefCount(ensemblePtr->unknownHandler);
2530 }
2531
2532 /*
2533 * Arrange for the structure to be reclaimed. Note that this is complex
2534 * because we have to make sure that we can react sensibly when an
2535 * ensemble is deleted during the process of initialising the ensemble
2536 * (especially the unknown callback.)
2537 */
2538
2539 Tcl_EventuallyFree(ensemblePtr, TCL_DYNAMIC);
2540 }
2541
2542 /*
2543 *----------------------------------------------------------------------
2544 *
2545 * BuildEnsembleConfig --
2546 *
2547 * Create the internal data structures that describe how an ensemble
2548 * looks, being a hash mapping from the full command name to the Tcl list
2549 * that describes the implementation prefix words, and a sorted array of
2550 * all the full command names to allow for reasonably efficient
2551 * unambiguous prefix handling.
2552 *
2553 * Results:
2554 * None.
2555 *
2556 * Side effects:
2557 * Reallocates and rebuilds the hash table and array stored at the
2558 * ensemblePtr argument. For large ensembles or large namespaces, this is
2559 * a potentially expensive operation.
2560 *
2561 *----------------------------------------------------------------------
2562 */
2563
2564 static void
BuildEnsembleConfig(EnsembleConfig * ensemblePtr)2565 BuildEnsembleConfig(
2566 EnsembleConfig *ensemblePtr)
2567 {
2568 Tcl_HashSearch search; /* Used for scanning the set of commands in
2569 * the namespace that backs up this
2570 * ensemble. */
2571 int i, j, isNew;
2572 Tcl_HashTable *hash = &ensemblePtr->subcommandTable;
2573 Tcl_HashEntry *hPtr;
2574 Tcl_Obj *mapDict = ensemblePtr->subcommandDict;
2575 Tcl_Obj *subList = ensemblePtr->subcmdList;
2576
2577 ClearTable(ensemblePtr);
2578 Tcl_InitHashTable(hash, TCL_STRING_KEYS);
2579
2580 if (subList) {
2581 int subc;
2582 Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj;
2583 const char *name;
2584
2585 /*
2586 * There is a list of exactly what subcommands go in the table.
2587 * Must determine the target for each.
2588 */
2589
2590 Tcl_ListObjGetElements(NULL, subList, &subc, &subv);
2591 if (subList == mapDict) {
2592 /*
2593 * Strange case where explicit list of subcommands is same value
2594 * as the dict mapping to targets.
2595 */
2596
2597 for (i = 0; i < subc; i += 2) {
2598 name = TclGetString(subv[i]);
2599 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2600 if (!isNew) {
2601 cmdObj = (Tcl_Obj *)Tcl_GetHashValue(hPtr);
2602 Tcl_DecrRefCount(cmdObj);
2603 }
2604 Tcl_SetHashValue(hPtr, subv[i+1]);
2605 Tcl_IncrRefCount(subv[i+1]);
2606
2607 name = TclGetString(subv[i+1]);
2608 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2609 if (isNew) {
2610 cmdObj = Tcl_NewStringObj(name, -1);
2611 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2612 Tcl_SetHashValue(hPtr, cmdPrefixObj);
2613 Tcl_IncrRefCount(cmdPrefixObj);
2614 }
2615 }
2616 } else {
2617 /*
2618 * Usual case where we can freely act on the list and dict.
2619 */
2620
2621 for (i = 0; i < subc; i++) {
2622 name = TclGetString(subv[i]);
2623 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2624 if (!isNew) {
2625 continue;
2626 }
2627
2628 /*
2629 * Lookup target in the dictionary.
2630 */
2631
2632 if (mapDict) {
2633 Tcl_DictObjGet(NULL, mapDict, subv[i], &target);
2634 if (target) {
2635 Tcl_SetHashValue(hPtr, target);
2636 Tcl_IncrRefCount(target);
2637 continue;
2638 }
2639 }
2640
2641 /*
2642 * target was not in the dictionary so map onto the namespace.
2643 * Note in this case that we do not guarantee that the command
2644 * is actually there; that is the programmer's responsibility
2645 * (or [::unknown] of course).
2646 */
2647
2648 cmdObj = Tcl_NewStringObj(name, -1);
2649 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2650 Tcl_SetHashValue(hPtr, cmdPrefixObj);
2651 Tcl_IncrRefCount(cmdPrefixObj);
2652 }
2653 }
2654 } else if (mapDict) {
2655 /*
2656 * No subcmd list, but we do have a mapping dictionary so we should
2657 * use the keys of that. Convert the dictionary's contents into the
2658 * form required for the ensemble's internal hashtable.
2659 */
2660
2661 Tcl_DictSearch dictSearch;
2662 Tcl_Obj *keyObj, *valueObj;
2663 int done;
2664
2665 Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch,
2666 &keyObj, &valueObj, &done);
2667 while (!done) {
2668 const char *name = TclGetString(keyObj);
2669
2670 hPtr = Tcl_CreateHashEntry(hash, name, &isNew);
2671 Tcl_SetHashValue(hPtr, valueObj);
2672 Tcl_IncrRefCount(valueObj);
2673 Tcl_DictObjNext(&dictSearch, &keyObj, &valueObj, &done);
2674 }
2675 } else {
2676 /*
2677 * Discover what commands are actually exported by the namespace.
2678 * What we have is an array of patterns and a hash table whose keys
2679 * are the command names exported by the namespace (the contents do
2680 * not matter here.) We must find out what commands are actually
2681 * exported by filtering each command in the namespace against each of
2682 * the patterns in the export list. Note that we use an intermediate
2683 * hash table to make memory management easier, and because that makes
2684 * exact matching far easier too.
2685 *
2686 * Suggestion for future enhancement: compute the unique prefixes and
2687 * place them in the hash too, which should make for even faster
2688 * matching.
2689 */
2690
2691 hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search);
2692 for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) {
2693 char *nsCmdName = /* Name of command in namespace. */
2694 (char *)Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr);
2695
2696 for (i=0 ; i<ensemblePtr->nsPtr->numExportPatterns ; i++) {
2697 if (Tcl_StringMatch(nsCmdName,
2698 ensemblePtr->nsPtr->exportArrayPtr[i])) {
2699 hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew);
2700
2701 /*
2702 * Remember, hash entries have a full reference to the
2703 * substituted part of the command (as a list) as their
2704 * content!
2705 */
2706
2707 if (isNew) {
2708 Tcl_Obj *cmdObj, *cmdPrefixObj;
2709
2710 TclNewObj(cmdObj);
2711 Tcl_AppendStringsToObj(cmdObj,
2712 ensemblePtr->nsPtr->fullName,
2713 (ensemblePtr->nsPtr->parentPtr ? "::" : ""),
2714 nsCmdName, NULL);
2715 cmdPrefixObj = Tcl_NewListObj(1, &cmdObj);
2716 Tcl_SetHashValue(hPtr, cmdPrefixObj);
2717 Tcl_IncrRefCount(cmdPrefixObj);
2718 }
2719 break;
2720 }
2721 }
2722 }
2723 }
2724
2725 if (hash->numEntries == 0) {
2726 ensemblePtr->subcommandArrayPtr = NULL;
2727 return;
2728 }
2729
2730 /*
2731 * Create a sorted array of all subcommands in the ensemble; hash tables
2732 * are all very well for a quick look for an exact match, but they can't
2733 * determine things like whether a string is a prefix of another (not
2734 * without lots of preparation anyway) and they're no good for when we're
2735 * generating the error message either.
2736 *
2737 * We do this by filling an array with the names (we use the hash keys
2738 * directly to save a copy, since any time we change the array we change
2739 * the hash too, and vice versa) and running quicksort over the array.
2740 */
2741
2742 ensemblePtr->subcommandArrayPtr =
2743 (char **)ckalloc(sizeof(char *) * hash->numEntries);
2744
2745 /*
2746 * Fill array from both ends as this makes us less likely to end up with
2747 * performance problems in qsort(), which is good. Note that doing this
2748 * makes this code much more opaque, but the naive alternatve:
2749 *
2750 * for (hPtr=Tcl_FirstHashEntry(hash,&search),i=0 ;
2751 * hPtr!=NULL ; hPtr=Tcl_NextHashEntry(&search),i++) {
2752 * ensemblePtr->subcommandArrayPtr[i] = Tcl_GetHashKey(hash, &hPtr);
2753 * }
2754 *
2755 * can produce long runs of precisely ordered table entries when the
2756 * commands in the namespace are declared in a sorted fashion (an ordering
2757 * some people like) and the hashing functions (or the command names
2758 * themselves) are fairly unfortunate. By filling from both ends, it
2759 * requires active malice (and probably a debugger) to get qsort() to have
2760 * awful runtime behaviour.
2761 */
2762
2763 i = 0;
2764 j = hash->numEntries;
2765 hPtr = Tcl_FirstHashEntry(hash, &search);
2766 while (hPtr != NULL) {
2767 ensemblePtr->subcommandArrayPtr[i++] = (char *)Tcl_GetHashKey(hash, hPtr);
2768 hPtr = Tcl_NextHashEntry(&search);
2769 if (hPtr == NULL) {
2770 break;
2771 }
2772 ensemblePtr->subcommandArrayPtr[--j] = (char *)Tcl_GetHashKey(hash, hPtr);
2773 hPtr = Tcl_NextHashEntry(&search);
2774 }
2775 if (hash->numEntries > 1) {
2776 qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries,
2777 sizeof(char *), NsEnsembleStringOrder);
2778 }
2779 }
2780
2781 /*
2782 *----------------------------------------------------------------------
2783 *
2784 * NsEnsembleStringOrder --
2785 *
2786 * Helper function to compare two pointers to two strings for use with
2787 * qsort().
2788 *
2789 * Results:
2790 * -1 if the first string is smaller, 1 if the second string is smaller,
2791 * and 0 if they are equal.
2792 *
2793 * Side effects:
2794 * None.
2795 *
2796 *----------------------------------------------------------------------
2797 */
2798
2799 static int
NsEnsembleStringOrder(const void * strPtr1,const void * strPtr2)2800 NsEnsembleStringOrder(
2801 const void *strPtr1,
2802 const void *strPtr2)
2803 {
2804 return strcmp(*(const char **)strPtr1, *(const char **)strPtr2);
2805 }
2806
2807 /*
2808 *----------------------------------------------------------------------
2809 *
2810 * FreeEnsembleCmdRep --
2811 *
2812 * Destroys the internal representation of a Tcl_Obj that has been
2813 * holding information about a command in an ensemble.
2814 *
2815 * Results:
2816 * None.
2817 *
2818 * Side effects:
2819 * Memory is deallocated. If this held the last reference to a
2820 * namespace's main structure, that main structure will also be
2821 * destroyed.
2822 *
2823 *----------------------------------------------------------------------
2824 */
2825
2826 static void
FreeEnsembleCmdRep(Tcl_Obj * objPtr)2827 FreeEnsembleCmdRep(
2828 Tcl_Obj *objPtr)
2829 {
2830 EnsembleCmdRep *ensembleCmd;
2831
2832 ECRGetIntRep(objPtr, ensembleCmd);
2833 TclCleanupCommandMacro(ensembleCmd->token);
2834 if (ensembleCmd->fix) {
2835 Tcl_DecrRefCount(ensembleCmd->fix);
2836 }
2837 ckfree(ensembleCmd);
2838 }
2839
2840 /*
2841 *----------------------------------------------------------------------
2842 *
2843 * DupEnsembleCmdRep --
2844 *
2845 * Makes one Tcl_Obj into a copy of another that is a subcommand of an
2846 * ensemble.
2847 *
2848 * Results:
2849 * None.
2850 *
2851 * Side effects:
2852 * Memory is allocated, and the namespace that the ensemble is built on
2853 * top of gains another reference.
2854 *
2855 *----------------------------------------------------------------------
2856 */
2857
2858 static void
DupEnsembleCmdRep(Tcl_Obj * objPtr,Tcl_Obj * copyPtr)2859 DupEnsembleCmdRep(
2860 Tcl_Obj *objPtr,
2861 Tcl_Obj *copyPtr)
2862 {
2863 EnsembleCmdRep *ensembleCmd;
2864 EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep));
2865
2866 ECRGetIntRep(objPtr, ensembleCmd);
2867 ECRSetIntRep(copyPtr, ensembleCopy);
2868
2869 ensembleCopy->epoch = ensembleCmd->epoch;
2870 ensembleCopy->token = ensembleCmd->token;
2871 ensembleCopy->token->refCount++;
2872 ensembleCopy->fix = ensembleCmd->fix;
2873 if (ensembleCopy->fix) {
2874 Tcl_IncrRefCount(ensembleCopy->fix);
2875 }
2876 ensembleCopy->hPtr = ensembleCmd->hPtr;
2877 }
2878
2879 /*
2880 *----------------------------------------------------------------------
2881 *
2882 * TclCompileEnsemble --
2883 *
2884 * Procedure called to compile an ensemble command. Note that most
2885 * ensembles are not compiled, since modifying a compiled ensemble causes
2886 * a invalidation of all existing bytecode (expensive!) which is not
2887 * normally warranted.
2888 *
2889 * Results:
2890 * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
2891 * evaluation to runtime.
2892 *
2893 * Side effects:
2894 * Instructions are added to envPtr to execute the subcommands of the
2895 * ensemble at runtime if a compile-time mapping is possible.
2896 *
2897 *----------------------------------------------------------------------
2898 */
2899
2900 int
TclCompileEnsemble(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)2901 TclCompileEnsemble(
2902 Tcl_Interp *interp, /* Used for error reporting. */
2903 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
2904 * created by Tcl_ParseCommand. */
2905 Command *cmdPtr, /* Points to defintion of command being
2906 * compiled. */
2907 CompileEnv *envPtr) /* Holds resulting instructions. */
2908 {
2909 DefineLineInformation;
2910 Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr);
2911 Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
2912 Tcl_Obj *replaced, *replacement;
2913 Tcl_Command ensemble = (Tcl_Command) cmdPtr;
2914 Command *oldCmdPtr = cmdPtr, *newCmdPtr;
2915 int len, result, flags = 0, i, depth = 1, invokeAnyway = 0;
2916 int ourResult = TCL_ERROR;
2917 unsigned numBytes;
2918 const char *word;
2919
2920 TclNewObj(replaced);
2921 Tcl_IncrRefCount(replaced);
2922 if (parsePtr->numWords < depth + 1) {
2923 goto failed;
2924 }
2925 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
2926 /*
2927 * Too hard.
2928 */
2929
2930 goto failed;
2931 }
2932
2933 /*
2934 * This is where we return to if we are parsing multiple nested compiled
2935 * ensembles. [info object] is such a beast.
2936 */
2937
2938 checkNextWord:
2939 word = tokenPtr[1].start;
2940 numBytes = tokenPtr[1].size;
2941
2942 /*
2943 * There's a sporting chance we'll be able to compile this. But now we
2944 * must check properly. To do that, check that we're compiling an ensemble
2945 * that has a compilable command as its appropriate subcommand.
2946 */
2947
2948 if (Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj) != TCL_OK
2949 || mapObj == NULL) {
2950 /*
2951 * Either not an ensemble or a mapping isn't installed. Crud. Too hard
2952 * to proceed.
2953 */
2954
2955 goto failed;
2956 }
2957
2958 /*
2959 * Also refuse to compile anything that uses a formal parameter list for
2960 * now, on the grounds that it is too complex.
2961 */
2962
2963 if (Tcl_GetEnsembleParameterList(NULL, ensemble, &listObj) != TCL_OK
2964 || listObj != NULL) {
2965 /*
2966 * Figuring out how to compile this has become too much. Bail out.
2967 */
2968
2969 goto failed;
2970 }
2971
2972 /*
2973 * Next, get the flags. We need them on several code paths so that we can
2974 * know whether we're to do prefix matching.
2975 */
2976
2977 (void) Tcl_GetEnsembleFlags(NULL, ensemble, &flags);
2978
2979 /*
2980 * Check to see if there's also a subcommand list; must check to see if
2981 * the subcommand we are calling is in that list if it exists, since that
2982 * list filters the entries in the map.
2983 */
2984
2985 (void) Tcl_GetEnsembleSubcommandList(NULL, ensemble, &listObj);
2986 if (listObj != NULL) {
2987 int sclen;
2988 const char *str;
2989 Tcl_Obj *matchObj = NULL;
2990
2991 if (Tcl_ListObjGetElements(NULL, listObj, &len, &elems) != TCL_OK) {
2992 goto failed;
2993 }
2994 for (i=0 ; i<len ; i++) {
2995 str = TclGetStringFromObj(elems[i], &sclen);
2996 if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) {
2997 /*
2998 * Exact match! Excellent!
2999 */
3000
3001 result = Tcl_DictObjGet(NULL, mapObj,elems[i], &targetCmdObj);
3002 if (result != TCL_OK || targetCmdObj == NULL) {
3003 goto failed;
3004 }
3005 replacement = elems[i];
3006 goto doneMapLookup;
3007 }
3008
3009 /*
3010 * Check to see if we've got a prefix match. A single prefix match
3011 * is fine, and allows us to refine our dictionary lookup, but
3012 * multiple prefix matches is a Bad Thing and will prevent us from
3013 * making progress. Note that we cannot do the lookup immediately
3014 * in the prefix case; might be another entry later in the list
3015 * that causes things to fail.
3016 */
3017
3018 if ((flags & TCL_ENSEMBLE_PREFIX)
3019 && strncmp(word, str, numBytes) == 0) {
3020 if (matchObj != NULL) {
3021 goto failed;
3022 }
3023 matchObj = elems[i];
3024 }
3025 }
3026 if (matchObj == NULL) {
3027 goto failed;
3028 }
3029 result = Tcl_DictObjGet(NULL, mapObj, matchObj, &targetCmdObj);
3030 if (result != TCL_OK || targetCmdObj == NULL) {
3031 goto failed;
3032 }
3033 replacement = matchObj;
3034 } else {
3035 Tcl_DictSearch s;
3036 int done, matched;
3037 Tcl_Obj *tmpObj;
3038
3039 /*
3040 * No map, so check the dictionary directly.
3041 */
3042
3043 TclNewStringObj(subcmdObj, word, (int) numBytes);
3044 result = Tcl_DictObjGet(NULL, mapObj, subcmdObj, &targetCmdObj);
3045 if (result == TCL_OK && targetCmdObj != NULL) {
3046 /*
3047 * Got it. Skip the fiddling around with prefixes.
3048 */
3049
3050 replacement = subcmdObj;
3051 goto doneMapLookup;
3052 }
3053 TclDecrRefCount(subcmdObj);
3054
3055 /*
3056 * We've not literally got a valid subcommand. But maybe we have a
3057 * prefix. Check if prefix matches are allowed.
3058 */
3059
3060 if (!(flags & TCL_ENSEMBLE_PREFIX)) {
3061 goto failed;
3062 }
3063
3064 /*
3065 * Iterate over the keys in the dictionary, checking to see if we're a
3066 * prefix.
3067 */
3068
3069 Tcl_DictObjFirst(NULL, mapObj, &s, &subcmdObj, &tmpObj, &done);
3070 matched = 0;
3071 replacement = NULL; /* Silence, fool compiler! */
3072 while (!done) {
3073 if (strncmp(TclGetString(subcmdObj), word, numBytes) == 0) {
3074 if (matched++) {
3075 /*
3076 * Must have matched twice! Not unique, so no point
3077 * looking further.
3078 */
3079
3080 break;
3081 }
3082 replacement = subcmdObj;
3083 targetCmdObj = tmpObj;
3084 }
3085 Tcl_DictObjNext(&s, &subcmdObj, &tmpObj, &done);
3086 }
3087 Tcl_DictObjDone(&s);
3088
3089 /*
3090 * If we have anything other than a single match, we've failed the
3091 * unique prefix check.
3092 */
3093
3094 if (matched != 1) {
3095 invokeAnyway = 1;
3096 goto failed;
3097 }
3098 }
3099
3100 /*
3101 * OK, we definitely map to something. But what?
3102 *
3103 * The command we map to is the first word out of the map element. Note
3104 * that we also reject dealing with multi-element rewrites if we are in a
3105 * safe interpreter, as there is otherwise a (highly gnarly!) way to make
3106 * Tcl crash open to exploit.
3107 */
3108
3109 doneMapLookup:
3110 Tcl_ListObjAppendElement(NULL, replaced, replacement);
3111 if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
3112 goto failed;
3113 } else if (len != 1) {
3114 /*
3115 * Note that at this point we know we can't issue any special
3116 * instruction sequence as the mapping isn't one that we support at
3117 * the compiled level.
3118 */
3119
3120 goto cleanup;
3121 }
3122 targetCmdObj = elems[0];
3123
3124 oldCmdPtr = cmdPtr;
3125 Tcl_IncrRefCount(targetCmdObj);
3126 newCmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
3127 TclDecrRefCount(targetCmdObj);
3128 if (newCmdPtr == NULL || Tcl_IsSafe(interp)
3129 || newCmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
3130 || newCmdPtr->flags & CMD_HAS_EXEC_TRACES
3131 || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
3132 /*
3133 * Maps to an undefined command or a command without a compiler.
3134 * Cannot compile.
3135 */
3136
3137 goto cleanup;
3138 }
3139 cmdPtr = newCmdPtr;
3140 depth++;
3141
3142 /*
3143 * See whether we have a nested ensemble. If we do, we can go round the
3144 * mulberry bush again, consuming the next word.
3145 */
3146
3147 if (cmdPtr->compileProc == TclCompileEnsemble) {
3148 tokenPtr = TokenAfter(tokenPtr);
3149 if (parsePtr->numWords < depth + 1
3150 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
3151 /*
3152 * Too hard because the user has done something unpleasant like
3153 * omitting the sub-ensemble's command name or used a non-constant
3154 * name for a sub-ensemble's command name; we respond by bailing
3155 * out completely (this is a rare case). [Bug 6d2f249a01]
3156 */
3157
3158 goto cleanup;
3159 }
3160 ensemble = (Tcl_Command) cmdPtr;
3161 goto checkNextWord;
3162 }
3163
3164 /*
3165 * Now that the mapping process is done we actually try to compile.
3166 * If there is a subcommand compiler and that successfully produces code,
3167 * we'll use that. Otherwise, we fall back to generating opcodes to do the
3168 * invoke at runtime.
3169 */
3170
3171 invokeAnyway = 1;
3172 if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, depth, cmdPtr,
3173 envPtr)) {
3174 ourResult = TCL_OK;
3175 goto cleanup;
3176 }
3177
3178 /*
3179 * Throw out any line information generated by the failed compile attempt.
3180 */
3181
3182 while (mapPtr->nuloc - 1 > eclIndex) {
3183 mapPtr->nuloc--;
3184 ckfree(mapPtr->loc[mapPtr->nuloc].line);
3185 mapPtr->loc[mapPtr->nuloc].line = NULL;
3186 }
3187
3188 /*
3189 * Reset the index of next command. Toss out any from failed nested
3190 * partial compiles.
3191 */
3192
3193 envPtr->numCommands = mapPtr->nuloc;
3194
3195 /*
3196 * Failed to do a full compile for some reason. Try to do a direct invoke
3197 * instead of going through the ensemble lookup process again.
3198 */
3199
3200 failed:
3201 if (depth < 250) {
3202 if (depth > 1) {
3203 if (!invokeAnyway) {
3204 cmdPtr = oldCmdPtr;
3205 depth--;
3206 }
3207 }
3208 /*
3209 * The length of the "replaced" list must be depth-1. Trim back
3210 * any extra elements that might have been appended by failing
3211 * pathways above.
3212 */
3213 (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL);
3214
3215 /*
3216 * TODO: Reconsider whether we ought to call CompileToInvokedCommand()
3217 * when depth==1. In that case we are choosing to emit the
3218 * INST_INVOKE_REPLACE bytecode when there is in fact no replacing
3219 * to be done. It would be equally functional and presumably more
3220 * performant to fall through to cleanup below, return TCL_ERROR,
3221 * and let the compiler harness emit the INST_INVOKE_STK
3222 * implementation for us.
3223 */
3224
3225 CompileToInvokedCommand(interp, parsePtr, replaced, cmdPtr, envPtr);
3226 ourResult = TCL_OK;
3227 }
3228
3229 /*
3230 * Release the memory we allocated. If we've got here, we've either done
3231 * something useful or we're in a case that we can't compile at all and
3232 * we're just giving up.
3233 */
3234
3235 cleanup:
3236 Tcl_DecrRefCount(replaced);
3237 return ourResult;
3238 }
3239
3240 int
TclAttemptCompileProc(Tcl_Interp * interp,Tcl_Parse * parsePtr,int depth,Command * cmdPtr,CompileEnv * envPtr)3241 TclAttemptCompileProc(
3242 Tcl_Interp *interp,
3243 Tcl_Parse *parsePtr,
3244 int depth,
3245 Command *cmdPtr,
3246 CompileEnv *envPtr) /* Holds resulting instructions. */
3247 {
3248 DefineLineInformation;
3249 int result, i;
3250 Tcl_Token *saveTokenPtr = parsePtr->tokenPtr;
3251 int savedStackDepth = envPtr->currStackDepth;
3252 unsigned savedCodeNext = envPtr->codeNext - envPtr->codeStart;
3253 int savedAuxDataArrayNext = envPtr->auxDataArrayNext;
3254 int savedExceptArrayNext = envPtr->exceptArrayNext;
3255 #ifdef TCL_COMPILE_DEBUG
3256 int savedExceptDepth = envPtr->exceptDepth;
3257 #endif
3258
3259 if (cmdPtr->compileProc == NULL) {
3260 return TCL_ERROR;
3261 }
3262
3263 /*
3264 * Advance parsePtr->tokenPtr so that it points at the last subcommand.
3265 * This will be wrong but it will not matter, and it will put the
3266 * tokens for the arguments in the right place without the need to
3267 * allocate a synthetic Tcl_Parse struct or copy tokens around.
3268 */
3269
3270 for (i = 0; i < depth - 1; i++) {
3271 parsePtr->tokenPtr = TokenAfter(parsePtr->tokenPtr);
3272 }
3273 parsePtr->numWords -= (depth - 1);
3274
3275 /*
3276 * Shift the line information arrays to account for different word
3277 * index values.
3278 */
3279
3280 mapPtr->loc[eclIndex].line += (depth - 1);
3281 mapPtr->loc[eclIndex].next += (depth - 1);
3282
3283 /*
3284 * Hand off compilation to the subcommand compiler. At last!
3285 */
3286
3287 result = cmdPtr->compileProc(interp, parsePtr, cmdPtr, envPtr);
3288
3289 /*
3290 * Undo the shift.
3291 */
3292
3293 mapPtr->loc[eclIndex].line -= (depth - 1);
3294 mapPtr->loc[eclIndex].next -= (depth - 1);
3295
3296 parsePtr->numWords += (depth - 1);
3297 parsePtr->tokenPtr = saveTokenPtr;
3298
3299 /*
3300 * If our target failed to compile, revert any data from failed partial
3301 * compiles. Note that envPtr->numCommands need not be checked because
3302 * we avoid compiling subcommands that recursively call TclCompileScript().
3303 */
3304
3305 #ifdef TCL_COMPILE_DEBUG
3306 if (envPtr->exceptDepth != savedExceptDepth) {
3307 Tcl_Panic("ExceptionRange Starts and Ends do not balance");
3308 }
3309 #endif
3310
3311 if (result != TCL_OK) {
3312 ExceptionAux *auxPtr = envPtr->exceptAuxArrayPtr;
3313
3314 for (i = 0; i < savedExceptArrayNext; i++) {
3315 while (auxPtr->numBreakTargets > 0
3316 && auxPtr->breakTargets[auxPtr->numBreakTargets - 1]
3317 >= savedCodeNext) {
3318 auxPtr->numBreakTargets--;
3319 }
3320 while (auxPtr->numContinueTargets > 0
3321 && auxPtr->continueTargets[auxPtr->numContinueTargets - 1]
3322 >= savedCodeNext) {
3323 auxPtr->numContinueTargets--;
3324 }
3325 auxPtr++;
3326 }
3327 envPtr->exceptArrayNext = savedExceptArrayNext;
3328
3329 if (savedAuxDataArrayNext != envPtr->auxDataArrayNext) {
3330 AuxData *auxDataPtr = envPtr->auxDataArrayPtr;
3331 AuxData *auxDataEnd = auxDataPtr;
3332
3333 auxDataPtr += savedAuxDataArrayNext;
3334 auxDataEnd += envPtr->auxDataArrayNext;
3335
3336 while (auxDataPtr < auxDataEnd) {
3337 if (auxDataPtr->type->freeProc != NULL) {
3338 auxDataPtr->type->freeProc(auxDataPtr->clientData);
3339 }
3340 auxDataPtr++;
3341 }
3342 envPtr->auxDataArrayNext = savedAuxDataArrayNext;
3343 }
3344 envPtr->currStackDepth = savedStackDepth;
3345 envPtr->codeNext = envPtr->codeStart + savedCodeNext;
3346 #ifdef TCL_COMPILE_DEBUG
3347 } else {
3348 /*
3349 * Confirm that the command compiler generated a single value on
3350 * the stack as its result. This is only done in debugging mode,
3351 * as it *should* be correct and normal users have no reasonable
3352 * way to fix it anyway.
3353 */
3354
3355 int diff = envPtr->currStackDepth - savedStackDepth;
3356
3357 if (diff != 1) {
3358 Tcl_Panic("bad stack adjustment when compiling"
3359 " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size,
3360 parsePtr->tokenPtr->start, diff);
3361 }
3362 #endif
3363 }
3364
3365 return result;
3366 }
3367
3368 /*
3369 * How to compile a subcommand to a _replacing_ invoke of its implementation
3370 * command.
3371 */
3372
3373 static void
CompileToInvokedCommand(Tcl_Interp * interp,Tcl_Parse * parsePtr,Tcl_Obj * replacements,Command * cmdPtr,CompileEnv * envPtr)3374 CompileToInvokedCommand(
3375 Tcl_Interp *interp,
3376 Tcl_Parse *parsePtr,
3377 Tcl_Obj *replacements,
3378 Command *cmdPtr,
3379 CompileEnv *envPtr) /* Holds resulting instructions. */
3380 {
3381 DefineLineInformation;
3382 Tcl_Token *tokPtr;
3383 Tcl_Obj *objPtr, **words;
3384 const char *bytes;
3385 int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
3386
3387 /*
3388 * Push the words of the command. Take care; the command words may be
3389 * scripts that have backslashes in them, and [info frame 0] can see the
3390 * difference. Hence the call to TclContinuationsEnterDerived...
3391 */
3392
3393 Tcl_ListObjGetElements(NULL, replacements, &numWords, &words);
3394 for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
3395 i++, tokPtr = TokenAfter(tokPtr)) {
3396 if (i > 0 && i < numWords+1) {
3397 bytes = TclGetString(words[i-1]);
3398 PushLiteral(envPtr, bytes, words[i-1]->length);
3399 continue;
3400 }
3401
3402 SetLineInformation(i);
3403 if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) {
3404 int literal = TclRegisterLiteral(envPtr,
3405 tokPtr[1].start, tokPtr[1].size, 0);
3406
3407 if (envPtr->clNext) {
3408 TclContinuationsEnterDerived(
3409 TclFetchLiteral(envPtr, literal),
3410 tokPtr[1].start - envPtr->source,
3411 envPtr->clNext);
3412 }
3413 TclEmitPush(literal, envPtr);
3414 } else {
3415 CompileTokens(envPtr, tokPtr, interp);
3416 }
3417 }
3418
3419 /*
3420 * Push the name of the command we're actually dispatching to as part of
3421 * the implementation.
3422 */
3423
3424 TclNewObj(objPtr);
3425 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
3426 bytes = TclGetString(objPtr);
3427 if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
3428 extraLiteralFlags |= LITERAL_UNSHARED;
3429 }
3430 cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
3431 TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
3432 TclEmitPush(cmdLit, envPtr);
3433 TclDecrRefCount(objPtr);
3434
3435 /*
3436 * Do the replacing dispatch.
3437 */
3438
3439 TclEmitInvoke(envPtr, INST_INVOKE_REPLACE, parsePtr->numWords,numWords+1);
3440 }
3441
3442 /*
3443 * Helpers that do issuing of instructions for commands that "don't have
3444 * compilers" (well, they do; these). They all work by just generating base
3445 * code to invoke the command; they're intended for ensemble subcommands so
3446 * that the costs of INST_INVOKE_REPLACE can be avoided where we can work out
3447 * that they're not needed.
3448 *
3449 * Note that these are NOT suitable for commands where there's an argument
3450 * that is a script, as an [info level] or [info frame] in the inner context
3451 * can see the difference.
3452 */
3453
3454 static int
CompileBasicNArgCommand(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3455 CompileBasicNArgCommand(
3456 Tcl_Interp *interp, /* Used for error reporting. */
3457 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3458 * created by Tcl_ParseCommand. */
3459 Command *cmdPtr, /* Points to defintion of command being
3460 * compiled. */
3461 CompileEnv *envPtr) /* Holds resulting instructions. */
3462 {
3463 Tcl_Obj *objPtr;
3464
3465 TclNewObj(objPtr);
3466 Tcl_IncrRefCount(objPtr);
3467 Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
3468 TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr,
3469 parsePtr->numWords, envPtr);
3470 Tcl_DecrRefCount(objPtr);
3471 return TCL_OK;
3472 }
3473
3474 int
TclCompileBasic0ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3475 TclCompileBasic0ArgCmd(
3476 Tcl_Interp *interp, /* Used for error reporting. */
3477 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3478 * created by Tcl_ParseCommand. */
3479 Command *cmdPtr, /* Points to defintion of command being
3480 * compiled. */
3481 CompileEnv *envPtr) /* Holds resulting instructions. */
3482 {
3483 /*
3484 * Verify that the number of arguments is correct; that's the only case
3485 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3486 * which is the only code that sees the shenanigans of ensemble dispatch.
3487 */
3488
3489 if (parsePtr->numWords != 1) {
3490 return TCL_ERROR;
3491 }
3492
3493 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3494 }
3495
3496 int
TclCompileBasic1ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3497 TclCompileBasic1ArgCmd(
3498 Tcl_Interp *interp, /* Used for error reporting. */
3499 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3500 * created by Tcl_ParseCommand. */
3501 Command *cmdPtr, /* Points to defintion of command being
3502 * compiled. */
3503 CompileEnv *envPtr) /* Holds resulting instructions. */
3504 {
3505 /*
3506 * Verify that the number of arguments is correct; that's the only case
3507 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3508 * which is the only code that sees the shenanigans of ensemble dispatch.
3509 */
3510
3511 if (parsePtr->numWords != 2) {
3512 return TCL_ERROR;
3513 }
3514
3515 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3516 }
3517
3518 int
TclCompileBasic2ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3519 TclCompileBasic2ArgCmd(
3520 Tcl_Interp *interp, /* Used for error reporting. */
3521 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3522 * created by Tcl_ParseCommand. */
3523 Command *cmdPtr, /* Points to defintion of command being
3524 * compiled. */
3525 CompileEnv *envPtr) /* Holds resulting instructions. */
3526 {
3527 /*
3528 * Verify that the number of arguments is correct; that's the only case
3529 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3530 * which is the only code that sees the shenanigans of ensemble dispatch.
3531 */
3532
3533 if (parsePtr->numWords != 3) {
3534 return TCL_ERROR;
3535 }
3536
3537 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3538 }
3539
3540 int
TclCompileBasic3ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3541 TclCompileBasic3ArgCmd(
3542 Tcl_Interp *interp, /* Used for error reporting. */
3543 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3544 * created by Tcl_ParseCommand. */
3545 Command *cmdPtr, /* Points to defintion of command being
3546 * compiled. */
3547 CompileEnv *envPtr) /* Holds resulting instructions. */
3548 {
3549 /*
3550 * Verify that the number of arguments is correct; that's the only case
3551 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3552 * which is the only code that sees the shenanigans of ensemble dispatch.
3553 */
3554
3555 if (parsePtr->numWords != 4) {
3556 return TCL_ERROR;
3557 }
3558
3559 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3560 }
3561
3562 int
TclCompileBasic0Or1ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3563 TclCompileBasic0Or1ArgCmd(
3564 Tcl_Interp *interp, /* Used for error reporting. */
3565 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3566 * created by Tcl_ParseCommand. */
3567 Command *cmdPtr, /* Points to defintion of command being
3568 * compiled. */
3569 CompileEnv *envPtr) /* Holds resulting instructions. */
3570 {
3571 /*
3572 * Verify that the number of arguments is correct; that's the only case
3573 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3574 * which is the only code that sees the shenanigans of ensemble dispatch.
3575 */
3576
3577 if (parsePtr->numWords != 1 && parsePtr->numWords != 2) {
3578 return TCL_ERROR;
3579 }
3580
3581 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3582 }
3583
3584 int
TclCompileBasic1Or2ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3585 TclCompileBasic1Or2ArgCmd(
3586 Tcl_Interp *interp, /* Used for error reporting. */
3587 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3588 * created by Tcl_ParseCommand. */
3589 Command *cmdPtr, /* Points to defintion of command being
3590 * compiled. */
3591 CompileEnv *envPtr) /* Holds resulting instructions. */
3592 {
3593 /*
3594 * Verify that the number of arguments is correct; that's the only case
3595 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3596 * which is the only code that sees the shenanigans of ensemble dispatch.
3597 */
3598
3599 if (parsePtr->numWords != 2 && parsePtr->numWords != 3) {
3600 return TCL_ERROR;
3601 }
3602
3603 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3604 }
3605
3606 int
TclCompileBasic2Or3ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3607 TclCompileBasic2Or3ArgCmd(
3608 Tcl_Interp *interp, /* Used for error reporting. */
3609 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3610 * created by Tcl_ParseCommand. */
3611 Command *cmdPtr, /* Points to defintion of command being
3612 * compiled. */
3613 CompileEnv *envPtr) /* Holds resulting instructions. */
3614 {
3615 /*
3616 * Verify that the number of arguments is correct; that's the only case
3617 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3618 * which is the only code that sees the shenanigans of ensemble dispatch.
3619 */
3620
3621 if (parsePtr->numWords != 3 && parsePtr->numWords != 4) {
3622 return TCL_ERROR;
3623 }
3624
3625 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3626 }
3627
3628 int
TclCompileBasic0To2ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3629 TclCompileBasic0To2ArgCmd(
3630 Tcl_Interp *interp, /* Used for error reporting. */
3631 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3632 * created by Tcl_ParseCommand. */
3633 Command *cmdPtr, /* Points to defintion of command being
3634 * compiled. */
3635 CompileEnv *envPtr) /* Holds resulting instructions. */
3636 {
3637 /*
3638 * Verify that the number of arguments is correct; that's the only case
3639 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3640 * which is the only code that sees the shenanigans of ensemble dispatch.
3641 */
3642
3643 if (parsePtr->numWords < 1 || parsePtr->numWords > 3) {
3644 return TCL_ERROR;
3645 }
3646
3647 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3648 }
3649
3650 int
TclCompileBasic1To3ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3651 TclCompileBasic1To3ArgCmd(
3652 Tcl_Interp *interp, /* Used for error reporting. */
3653 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3654 * created by Tcl_ParseCommand. */
3655 Command *cmdPtr, /* Points to defintion of command being
3656 * compiled. */
3657 CompileEnv *envPtr) /* Holds resulting instructions. */
3658 {
3659 /*
3660 * Verify that the number of arguments is correct; that's the only case
3661 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3662 * which is the only code that sees the shenanigans of ensemble dispatch.
3663 */
3664
3665 if (parsePtr->numWords < 2 || parsePtr->numWords > 4) {
3666 return TCL_ERROR;
3667 }
3668
3669 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3670 }
3671
3672 int
TclCompileBasicMin0ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3673 TclCompileBasicMin0ArgCmd(
3674 Tcl_Interp *interp, /* Used for error reporting. */
3675 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3676 * created by Tcl_ParseCommand. */
3677 Command *cmdPtr, /* Points to defintion of command being
3678 * compiled. */
3679 CompileEnv *envPtr) /* Holds resulting instructions. */
3680 {
3681 /*
3682 * Verify that the number of arguments is correct; that's the only case
3683 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3684 * which is the only code that sees the shenanigans of ensemble dispatch.
3685 */
3686
3687 if (parsePtr->numWords < 1) {
3688 return TCL_ERROR;
3689 }
3690
3691 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3692 }
3693
3694 int
TclCompileBasicMin1ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3695 TclCompileBasicMin1ArgCmd(
3696 Tcl_Interp *interp, /* Used for error reporting. */
3697 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3698 * created by Tcl_ParseCommand. */
3699 Command *cmdPtr, /* Points to defintion of command being
3700 * compiled. */
3701 CompileEnv *envPtr) /* Holds resulting instructions. */
3702 {
3703 /*
3704 * Verify that the number of arguments is correct; that's the only case
3705 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3706 * which is the only code that sees the shenanigans of ensemble dispatch.
3707 */
3708
3709 if (parsePtr->numWords < 2) {
3710 return TCL_ERROR;
3711 }
3712
3713 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3714 }
3715
3716 int
TclCompileBasicMin2ArgCmd(Tcl_Interp * interp,Tcl_Parse * parsePtr,Command * cmdPtr,CompileEnv * envPtr)3717 TclCompileBasicMin2ArgCmd(
3718 Tcl_Interp *interp, /* Used for error reporting. */
3719 Tcl_Parse *parsePtr, /* Points to a parse structure for the command
3720 * created by Tcl_ParseCommand. */
3721 Command *cmdPtr, /* Points to defintion of command being
3722 * compiled. */
3723 CompileEnv *envPtr) /* Holds resulting instructions. */
3724 {
3725 /*
3726 * Verify that the number of arguments is correct; that's the only case
3727 * that we know will avoid the call to Tcl_WrongNumArgs() at invoke time,
3728 * which is the only code that sees the shenanigans of ensemble dispatch.
3729 */
3730
3731 if (parsePtr->numWords < 3) {
3732 return TCL_ERROR;
3733 }
3734
3735 return CompileBasicNArgCommand(interp, parsePtr, cmdPtr, envPtr);
3736 }
3737
3738 /*
3739 * Local Variables:
3740 * mode: c
3741 * c-basic-offset: 4
3742 * fill-column: 78
3743 * End:
3744 */
3745