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