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