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