Planet

navi

home

PPS

about

screenshots

download

development

forum

Context Navigation

source: downloads/tcl8.5.2/generic/tclParse.c @ 35

Last change on this file since 35 was 25, checked in by landauf, 17 years ago
added tcl to libs
File size: 70.2 KB

Line
1	/*
2	* tclParse.c --
3	*
4	* This file contains functions that parse Tcl scripts. They do so in a
5	* general-purpose fashion that can be used for many different purposes,
6	* including compilation, direct execution, code analysis, etc.
7	*
8	* Copyright (c) 1997 Sun Microsystems, Inc.
9	* Copyright (c) 1998-2000 Ajuba Solutions.
10	* Contributions from Don Porter, NIST, 2002. (not subject to US copyright)
11	*
12	* See the file "license.terms" for information on usage and redistribution of
13	* this file, and for a DISCLAIMER OF ALL WARRANTIES.
14	*
15	* RCS: @(#) $Id: tclParse.c,v 1.62 2008/01/23 21:58:36 dgp Exp $
16	*/
17
18	#include "tclInt.h"
19
20	/*
21	* The following table provides parsing information about each possible 8-bit
22	* character. The table is designed to be referenced with either signed or
23	* unsigned characters, so it has 384 entries. The first 128 entries
24	* correspond to negative character values, the next 256 correspond to
25	* positive character values. The last 128 entries are identical to the first
26	* 128. The table is always indexed with a 128-byte offset (the 128th entry
27	* corresponds to a character value of 0).
28	*
29	* The macro CHAR_TYPE is used to index into the table and return information
30	* about its character argument. The following return values are defined.
31	*
32	* TYPE_NORMAL - All characters that don't have special significance to
33	* the Tcl parser.
34	* TYPE_SPACE - The character is a whitespace character other than
35	* newline.
36	* TYPE_COMMAND_END - Character is newline or semicolon.
37	* TYPE_SUBS - Character begins a substitution or has other special
38	* meaning in ParseTokens: backslash, dollar sign, or
39	* open bracket.
40	* TYPE_QUOTE - Character is a double quote.
41	* TYPE_CLOSE_PAREN - Character is a right parenthesis.
42	* TYPE_CLOSE_BRACK - Character is a right square bracket.
43	* TYPE_BRACE - Character is a curly brace (either left or right).
44	*/
45
46	#define TYPE_NORMAL 0
47	#define TYPE_SPACE 0x1
48	#define TYPE_COMMAND_END 0x2
49	#define TYPE_SUBS 0x4
50	#define TYPE_QUOTE 0x8
51	#define TYPE_CLOSE_PAREN 0x10
52	#define TYPE_CLOSE_BRACK 0x20
53	#define TYPE_BRACE 0x40
54
55	#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
56
57	static const char charTypeTable[] = {
58	/*
59	* Negative character values, from -128 to -1:
60	*/
61
62	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
63	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
64	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
65	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
66	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
67	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
68	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
69	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
70	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
71	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
72	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
73	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
74	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
75	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
76	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
77	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
78	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
79	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
80	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
81	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
82	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
83	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
84	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
85	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
86	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
87	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
88	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
89	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
90	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
91	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
92	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
93	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
94
95	/*
96	* Positive character values, from 0-127:
97	*/
98
99	TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
100	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
101	TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
102	TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
103	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
104	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
105	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
106	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
107	TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
108	TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
109	TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL,
110	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
111	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
112	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
113	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END,
114	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
115	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
116	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
117	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
118	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
119	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
120	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
121	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS,
122	TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
123	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
124	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
125	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
126	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
127	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
128	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
129	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
130	TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
131
132	/*
133	* Large unsigned character values, from 128-255:
134	*/
135
136	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
137	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
138	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
139	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
140	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
141	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
142	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
143	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
144	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
145	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
146	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
147	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
148	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
149	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
150	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
151	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
152	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
153	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
154	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
155	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
156	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
157	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
158	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
159	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
160	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
161	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
162	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
163	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
164	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
165	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
166	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
167	TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
168	};
169
170	/*
171	* Prototypes for local functions defined in this file:
172	*/
173
174	static inline int CommandComplete(const char *script, int numBytes);
175	static int ParseComment(const char *src, int numBytes,
176	Tcl_Parse *parsePtr);
177	static int ParseTokens(const char *src, int numBytes, int mask,
178	int flags, Tcl_Parse *parsePtr);
179	static int ParseWhiteSpace(const char *src, int numBytes,
180	int incompletePtr, char typePtr);
181
182	/*
183	*----------------------------------------------------------------------
184	*
185	* TclParseInit --
186	*
187	* Initialize the fields of a Tcl_Parse struct.
188	*
189	* Results:
190	* None.
191	*
192	* Side effects:
193	* The Tcl_Parse struct pointed to by parsePtr gets initialized.
194	*
195	*----------------------------------------------------------------------
196	*/
197
198	void
199	TclParseInit(
200	Tcl_Interp interp, / Interpreter to use for error reporting */
201	const char start, / Start of string to be parsed. */
202	int numBytes, /* Total number of bytes in string. If < 0,
203	* the script consists of all bytes up to the
204	* first null character. */
205	Tcl_Parse parsePtr) / Points to struct to initialize */
206	{
207	parsePtr->numWords = 0;
208	parsePtr->tokenPtr = parsePtr->staticTokens;
209	parsePtr->numTokens = 0;
210	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
211	parsePtr->string = start;
212	parsePtr->end = start + numBytes;
213	parsePtr->term = parsePtr->end;
214	parsePtr->interp = interp;
215	parsePtr->incomplete = 0;
216	parsePtr->errorType = TCL_PARSE_SUCCESS;
217	}
218
219	/*
220	*----------------------------------------------------------------------
221	*
222	* Tcl_ParseCommand --
223	*
224	* Given a string, this function parses the first Tcl command in the
225	* string and returns information about the structure of the command.
226	*
227	* Results:
228	* The return value is TCL_OK if the command was parsed successfully and
229	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
230	* error message is left in its result. On a successful return, parsePtr
231	* is filled in with information about the command that was parsed.
232	*
233	* Side effects:
234	* If there is insufficient space in parsePtr to hold all the information
235	* about the command, then additional space is malloc-ed. If the function
236	* returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
237	* release any additional space that was allocated.
238	*
239	*----------------------------------------------------------------------
240	*/
241
242	int
243	Tcl_ParseCommand(
244	Tcl_Interp interp, / Interpreter to use for error reporting; if
245	* NULL, then no error message is provided. */
246	const char start, / First character of string containing one or
247	* more Tcl commands. */
248	register int numBytes, /* Total number of bytes in string. If < 0,
249	* the script consists of all bytes up to the
250	* first null character. */
251	int nested, /* Non-zero means this is a nested command:
252	* close bracket should be considered a
253	* command terminator. If zero, then close
254	* bracket has no special meaning. */
255	register Tcl_Parse *parsePtr)
256	/* Structure to fill in with information about
257	* the parsed command; any previous
258	* information in the structure is ignored. */
259	{
260	register const char src; / Points to current character in the
261	* command. */
262	char type; /* Result returned by CHAR_TYPE(src). /
263	Tcl_Token tokenPtr; / Pointer to token being filled in. */
264	int wordIndex; /* Index of word token for current word. */
265	int terminators; /* CHAR_TYPE bits that indicate the end of a
266	* command. */
267	const char termPtr; / Set by Tcl_ParseBraces/QuotedString to
268	* point to char after terminating one. */
269	int scanned;
270
271	if ((start == NULL) && (numBytes != 0)) {
272	if (interp != NULL) {
273	Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC);
274	}
275	return TCL_ERROR;
276	}
277	if (numBytes < 0) {
278	numBytes = strlen(start);
279	}
280	TclParseInit(interp, start, numBytes, parsePtr);
281	parsePtr->commentStart = NULL;
282	parsePtr->commentSize = 0;
283	parsePtr->commandStart = NULL;
284	parsePtr->commandSize = 0;
285	if (nested != 0) {
286	terminators = TYPE_COMMAND_END \| TYPE_CLOSE_BRACK;
287	} else {
288	terminators = TYPE_COMMAND_END;
289	}
290
291	/*
292	* Parse any leading space and comments before the first word of the
293	* command.
294	*/
295
296	scanned = ParseComment(start, numBytes, parsePtr);
297	src = (start + scanned);
298	numBytes -= scanned;
299	if (numBytes == 0) {
300	if (nested) {
301	parsePtr->incomplete = nested;
302	}
303	}
304
305	/*
306	* The following loop parses the words of the command, one word in each
307	* iteration through the loop.
308	*/
309
310	parsePtr->commandStart = src;
311	while (1) {
312	int expandWord = 0;
313
314	/*
315	* Create the token for the word.
316	*/
317
318	TclGrowParseTokenArray(parsePtr, 1);
319	wordIndex = parsePtr->numTokens;
320	tokenPtr = &parsePtr->tokenPtr[wordIndex];
321	tokenPtr->type = TCL_TOKEN_WORD;
322
323	/*
324	* Skip white space before the word. Also skip a backslash-newline
325	* sequence: it should be treated just like white space.
326	*/
327
328	scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
329	src += scanned;
330	numBytes -= scanned;
331	if (numBytes == 0) {
332	parsePtr->term = src;
333	break;
334	}
335	if ((type & terminators) != 0) {
336	parsePtr->term = src;
337	src++;
338	break;
339	}
340	tokenPtr->start = src;
341	parsePtr->numTokens++;
342	parsePtr->numWords++;
343
344	/*
345	* At this point the word can have one of four forms: something
346	* enclosed in quotes, something enclosed in braces, and expanding
347	* word, or an unquoted word (anything else).
348	*/
349
350	parseWord:
351	if (*src == '"') {
352	if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1,
353	&termPtr) != TCL_OK) {
354	goto error;
355	}
356	src = termPtr;
357	numBytes = parsePtr->end - src;
358	} else if (*src == '{') {
359	int expIdx = wordIndex + 1;
360	Tcl_Token *expPtr;
361
362	if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1,
363	&termPtr) != TCL_OK) {
364	goto error;
365	}
366	src = termPtr;
367	numBytes = parsePtr->end - src;
368
369	/*
370	* Check whether the braces contained the word expansion prefix
371	* {*}
372	*/
373
374	expPtr = &parsePtr->tokenPtr[expIdx];
375	if ((0 == expandWord)
376	/* Haven't seen prefix already */
377	&& (1 == parsePtr->numTokens - expIdx)
378	/* Only one token */
379	&& (((1 == (size_t) expPtr->size)
380	/* Same length as prefix */
381	&& (expPtr->start[0] == '*')))
382	/* Is the prefix */
383	&& (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
384	numBytes, &parsePtr->incomplete, &type))
385	&& (type != TYPE_COMMAND_END)
386	/* Non-whitespace follows */) {
387	expandWord = 1;
388	parsePtr->numTokens--;
389	goto parseWord;
390	}
391	} else {
392	/*
393	* This is an unquoted word. Call ParseTokens and let it do all of
394	* the work.
395	*/
396
397	if (ParseTokens(src, numBytes, TYPE_SPACE\|terminators,
398	TCL_SUBST_ALL, parsePtr) != TCL_OK) {
399	goto error;
400	}
401	src = parsePtr->term;
402	numBytes = parsePtr->end - src;
403	}
404
405	/*
406	* Finish filling in the token for the word and check for the special
407	* case of a word consisting of a single range of literal text.
408	*/
409
410	tokenPtr = &parsePtr->tokenPtr[wordIndex];
411	tokenPtr->size = src - tokenPtr->start;
412	tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
413	if (expandWord) {
414	int i, isLiteral = 1;
415
416	/*
417	* When a command includes a word that is an expanded literal; for
418	* example, {*}{1 2 3}, the parser performs that expansion
419	* immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
420	* of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
421	* caller might have to expand. This notably makes it simpler for
422	* those callers that wish to track line endings, such as those
423	* that implement key parts of TIP 280.
424	*
425	* First check whether the thing to be expanded is a literal,
426	* in the sense of being composed entirely of TCL_TOKEN_TEXT
427	* tokens.
428	*/
429
430	for (i = 1; i <= tokenPtr->numComponents; i++) {
431	if (tokenPtr[i].type != TCL_TOKEN_TEXT) {
432	isLiteral = 0;
433	break;
434	}
435	}
436
437	if (isLiteral) {
438	int elemCount = 0, code = TCL_OK;
439	const char nextElem, listEnd, *elemStart;
440
441	/*
442	* The word to be expanded is a literal, so determine the
443	* boundaries of the literal string to be treated as a list
444	* and expanded. That literal string starts at
445	* tokenPtr[1].start, and includes all bytes up to, but not
446	* including (tokenPtr[tokenPtr->numComponents].start +
447	* tokenPtr[tokenPtr->numComponents].size)
448	*/
449
450	listEnd = (tokenPtr[tokenPtr->numComponents].start +
451	tokenPtr[tokenPtr->numComponents].size);
452	nextElem = tokenPtr[1].start;
453
454	/*
455	* Step through the literal string, parsing and counting list
456	* elements.
457	*/
458
459	while (nextElem < listEnd) {
460	code = TclFindElement(NULL, nextElem, listEnd - nextElem,
461	&elemStart, &nextElem, NULL, NULL);
462	if (code != TCL_OK) break;
463	if (elemStart < listEnd) {
464	elemCount++;
465	}
466	}
467
468	if (code != TCL_OK) {
469	/*
470	* Some list element could not be parsed. This means the
471	* literal string was not in fact a valid list. Defer the
472	* handling of this to compile/eval time, where code is
473	* already in place to report the "attempt to expand a
474	* non-list" error.
475	*/
476
477	tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
478	} else if (elemCount == 0) {
479	/*
480	* We are expanding a literal empty list. This means that
481	* the expanding word completely disappears, leaving no
482	* word generated this pass through the loop. Adjust
483	* accounting appropriately.
484	*/
485
486	parsePtr->numWords--;
487	parsePtr->numTokens = wordIndex;
488	} else {
489	/*
490	* Recalculate the number of Tcl_Tokens needed to store
491	* tokens representing the expanded list.
492	*/
493
494	int growthNeeded = wordIndex + 2*elemCount
495	- parsePtr->numTokens;
496	parsePtr->numWords += elemCount - 1;
497	if (growthNeeded > 0) {
498	TclGrowParseTokenArray(parsePtr, growthNeeded);
499	tokenPtr = &parsePtr->tokenPtr[wordIndex];
500	}
501	parsePtr->numTokens = wordIndex + 2*elemCount;
502
503	/*
504	* Generate a TCL_TOKEN_SIMPLE_WORD token sequence for
505	* each element of the literal list we are expanding in
506	* place. Take care with the start and size fields of each
507	* token so they point to the right literal characters in
508	* the original script to represent the right expanded
509	* word value.
510	*/
511
512	nextElem = tokenPtr[1].start;
513	while (isspace(UCHAR(*nextElem))) {
514	nextElem++;
515	}
516	while (nextElem < listEnd) {
517	tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
518	tokenPtr->numComponents = 1;
519	tokenPtr->start = nextElem;
520
521	tokenPtr++;
522	tokenPtr->type = TCL_TOKEN_TEXT;
523	tokenPtr->numComponents = 0;
524	TclFindElement(NULL, nextElem, listEnd - nextElem,
525	&(tokenPtr->start), &nextElem,
526	&(tokenPtr->size), NULL);
527	if (tokenPtr->start + tokenPtr->size == listEnd) {
528	tokenPtr[-1].size = listEnd - tokenPtr[-1].start;
529	} else {
530	tokenPtr[-1].size = tokenPtr->start
531	+ tokenPtr->size - tokenPtr[-1].start;
532	tokenPtr[-1].size += (isspace(UCHAR(
533	tokenPtr->start[tokenPtr->size])) == 0);
534	}
535
536	tokenPtr++;
537	}
538	}
539	} else {
540	/*
541	* The word to be expanded is not a literal, so defer
542	* expansion to compile/eval time by marking with a
543	* TCL_TOKEN_EXPAND_WORD token.
544	*/
545
546	tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
547	}
548	} else if ((tokenPtr->numComponents == 1)
549	&& (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
550	tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
551	}
552
553	/*
554	* Do two additional checks: (a) make sure we're really at the end of
555	* a word (there might have been garbage left after a quoted or braced
556	* word), and (b) check for the end of the command.
557	*/
558
559	scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
560	if (scanned) {
561	src += scanned;
562	numBytes -= scanned;
563	continue;
564	}
565
566	if (numBytes == 0) {
567	parsePtr->term = src;
568	break;
569	}
570	if ((type & terminators) != 0) {
571	parsePtr->term = src;
572	src++;
573	break;
574	}
575	if (src[-1] == '"') {
576	if (interp != NULL) {
577	Tcl_SetResult(interp, "extra characters after close-quote",
578	TCL_STATIC);
579	}
580	parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
581	} else {
582	if (interp != NULL) {
583	Tcl_SetResult(interp, "extra characters after close-brace",
584	TCL_STATIC);
585	}
586	parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
587	}
588	parsePtr->term = src;
589	goto error;
590	}
591
592	parsePtr->commandSize = src - parsePtr->commandStart;
593	return TCL_OK;
594
595	error:
596	Tcl_FreeParse(parsePtr);
597	parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
598	return TCL_ERROR;
599	}
600
601	/*
602	*----------------------------------------------------------------------
603	*
604	* ParseWhiteSpace --
605	*
606	* Scans up to numBytes bytes starting at src, consuming white space
607	* between words as defined by Tcl's parsing rules.
608	*
609	* Results:
610	* Returns the number of bytes recognized as white space. Records at
611	* parsePtr, information about the parse. Records at typePtr the
612	* character type of the non-whitespace character that terminated the
613	* scan.
614	*
615	* Side effects:
616	* None.
617	*
618	*----------------------------------------------------------------------
619	*/
620
621	static int
622	ParseWhiteSpace(
623	const char src, / First character to parse. */
624	register int numBytes, /* Max number of bytes to scan. */
625	int incompletePtr, / Set this boolean memory to true if parsing
626	* indicates an incomplete command. */
627	char typePtr) / Points to location to store character type
628	* of character that ends run of whitespace */
629	{
630	register char type = TYPE_NORMAL;
631	register const char *p = src;
632
633	while (1) {
634	while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
635	numBytes--;
636	p++;
637	}
638	if (numBytes && (type & TYPE_SUBS)) {
639	if (*p != '\\') {
640	break;
641	}
642	if (--numBytes == 0) {
643	break;
644	}
645	if (p[1] != '\n') {
646	break;
647	}
648	p+=2;
649	if (--numBytes == 0) {
650	*incompletePtr = 1;
651	break;
652	}
653	continue;
654	}
655	break;
656	}
657	*typePtr = type;
658	return (p - src);
659	}
660
661	/*
662	*----------------------------------------------------------------------
663	*
664	* TclParseAllWhiteSpace --
665	*
666	* Scans up to numBytes bytes starting at src, consuming all white space
667	* including the command-terminating newline characters.
668	*
669	* Results:
670	* Returns the number of bytes recognized as white space.
671	*
672	*----------------------------------------------------------------------
673	*/
674
675	int
676	TclParseAllWhiteSpace(
677	const char src, / First character to parse. */
678	int numBytes) /* Max number of byes to scan */
679	{
680	int dummy;
681	char type;
682	const char *p = src;
683
684	do {
685	int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type);
686
687	p += scanned;
688	numBytes -= scanned;
689	} while (numBytes && (*p == '\n') && (p++, --numBytes));
690	return (p-src);
691	}
692
693	/*
694	*----------------------------------------------------------------------
695	*
696	* TclParseHex --
697	*
698	* Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing
699	* \x and \u escape sequences). At most numBytes bytes are scanned.
700	*
701	* Results:
702	* The numeric value is stored in *resultPtr. Returns the number of bytes
703	* consumed.
704	*
705	* Notes:
706	* Relies on the following properties of the ASCII character set, with
707	* which UTF-8 is compatible:
708	*
709	* The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy
710	* consecutive code points, and '0' < 'A' < 'a'.
711	*
712	*----------------------------------------------------------------------
713	*/
714
715	int
716	TclParseHex(
717	const char src, / First character to parse. */
718	int numBytes, /* Max number of byes to scan */
719	Tcl_UniChar resultPtr) / Points to storage provided by caller where
720	* the Tcl_UniChar resulting from the
721	* conversion is to be written. */
722	{
723	Tcl_UniChar result = 0;
724	register const char *p = src;
725
726	while (numBytes--) {
727	unsigned char digit = UCHAR(*p);
728
729	if (!isxdigit(digit)) {
730	break;
731	}
732
733	++p;
734	result <<= 4;
735
736	if (digit >= 'a') {
737	result \|= (10 + digit - 'a');
738	} else if (digit >= 'A') {
739	result \|= (10 + digit - 'A');
740	} else {
741	result \|= (digit - '0');
742	}
743	}
744
745	*resultPtr = result;
746	return (p - src);
747	}
748
749	/*
750	*----------------------------------------------------------------------
751	*
752	* TclParseBackslash --
753	*
754	* Scans up to numBytes bytes starting at src, consuming a backslash
755	* sequence as defined by Tcl's parsing rules.
756	*
757	* Results:
758	* Records at readPtr the number of bytes making up the backslash
759	* sequence. Records at dst the UTF-8 encoded equivalent of that
760	* backslash sequence. Returns the number of bytes written to dst, at
761	* most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results
762	* are not needed, but the return value is the same either way.
763	*
764	* Side effects:
765	* None.
766	*
767	*----------------------------------------------------------------------
768	*/
769
770	int
771	TclParseBackslash(
772	const char src, / Points to the backslash character of a a
773	* backslash sequence. */
774	int numBytes, /* Max number of bytes to scan. */
775	int readPtr, / NULL, or points to storage where the number
776	* of bytes scanned should be written. */
777	char dst) / NULL, or points to buffer where the UTF-8
778	* encoding of the backslash sequence is to be
779	* written. At most TCL_UTF_MAX bytes will be
780	* written there. */
781	{
782	register const char *p = src+1;
783	Tcl_UniChar result;
784	int count;
785	char buf[TCL_UTF_MAX];
786
787	if (numBytes == 0) {
788	if (readPtr != NULL) {
789	*readPtr = 0;
790	}
791	return 0;
792	}
793
794	if (dst == NULL) {
795	dst = buf;
796	}
797
798	if (numBytes == 1) {
799	/*
800	* Can only scan the backslash, so return it.
801	*/
802
803	result = '\\';
804	count = 1;
805	goto done;
806	}
807
808	count = 2;
809	switch (*p) {
810	/*
811	* Note: in the conversions below, use absolute values (e.g., 0xa)
812	* rather than symbolic values (e.g. \n) that get converted by the
813	* compiler. It's possible that compilers on some platforms will do
814	* the symbolic conversions differently, which could result in
815	* non-portable Tcl scripts.
816	*/
817
818	case 'a':
819	result = 0x7;
820	break;
821	case 'b':
822	result = 0x8;
823	break;
824	case 'f':
825	result = 0xc;
826	break;
827	case 'n':
828	result = 0xa;
829	break;
830	case 'r':
831	result = 0xd;
832	break;
833	case 't':
834	result = 0x9;
835	break;
836	case 'v':
837	result = 0xb;
838	break;
839	case 'x':
840	count += TclParseHex(p+1, numBytes-1, &result);
841	if (count == 2) {
842	/*
843	* No hexadigits -> This is just "x".
844	*/
845
846	result = 'x';
847	} else {
848	/*
849	* Keep only the last byte (2 hex digits).
850	*/
851	result = (unsigned char) result;
852	}
853	break;
854	case 'u':
855	count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result);
856	if (count == 2) {
857	/*
858	* No hexadigits -> This is just "u".
859	*/
860	result = 'u';
861	}
862	break;
863	case '\n':
864	count--;
865	do {
866	p++;
867	count++;
868	} while ((count < numBytes) && ((p == ' ') \|\| (p == '\t')));
869	result = ' ';
870	break;
871	case 0:
872	result = '\\';
873	count = 1;
874	break;
875	default:
876	/*
877	* Check for an octal number \oo?o?
878	*/
879
880	if (isdigit(UCHAR(p)) && (UCHAR(p) < '8')) { /* INTL: digit */
881	result = (unsigned char)(*p - '0');
882	p++;
883	if ((numBytes == 2) \|\| !isdigit(UCHAR(p)) / INTL: digit */
884	\|\| (UCHAR(*p) >= '8')) {
885	break;
886	}
887	count = 3;
888	result = (unsigned char)((result << 3) + (*p - '0'));
889	p++;
890	if ((numBytes == 3) \|\| !isdigit(UCHAR(p)) / INTL: digit */
891	\|\| (UCHAR(*p) >= '8')) {
892	break;
893	}
894	count = 4;
895	result = (unsigned char)((result << 3) + (*p - '0'));
896	break;
897	}
898
899	/*
900	* We have to convert here in case the user has put a backslash in
901	* front of a multi-byte utf-8 character. While this means nothing
902	* special, we shouldn't break up a correct utf-8 character. [Bug
903	* #217987] test subst-3.2
904	*/
905
906	if (Tcl_UtfCharComplete(p, numBytes - 1)) {
907	count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */
908	} else {
909	char utfBytes[TCL_UTF_MAX];
910
911	memcpy(utfBytes, p, (size_t) (numBytes - 1));
912	utfBytes[numBytes - 1] = '\0';
913	count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
914	}
915	break;
916	}
917
918	done:
919	if (readPtr != NULL) {
920	*readPtr = count;
921	}
922	return Tcl_UniCharToUtf((int) result, dst);
923	}
924
925	/*
926	*----------------------------------------------------------------------
927	*
928	* ParseComment --
929	*
930	* Scans up to numBytes bytes starting at src, consuming a Tcl comment as
931	* defined by Tcl's parsing rules.
932	*
933	* Results:
934	* Records in parsePtr information about the parse. Returns the number of
935	* bytes consumed.
936	*
937	* Side effects:
938	* None.
939	*
940	*----------------------------------------------------------------------
941	*/
942
943	static int
944	ParseComment(
945	const char src, / First character to parse. */
946	register int numBytes, /* Max number of bytes to scan. */
947	Tcl_Parse parsePtr) / Information about parse in progress.
948	* Updated if parsing indicates an incomplete
949	* command. */
950	{
951	register const char *p = src;
952
953	while (numBytes) {
954	char type;
955	int scanned;
956
957	scanned = TclParseAllWhiteSpace(p, numBytes);
958	p += scanned;
959	numBytes -= scanned;
960
961	if ((numBytes == 0) \|\| (*p != '#')) {
962	break;
963	}
964	if (parsePtr->commentStart == NULL) {
965	parsePtr->commentStart = p;
966	}
967
968	while (numBytes) {
969	if (*p == '\\') {
970	scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete,
971	&type);
972	if (scanned) {
973	p += scanned;
974	numBytes -= scanned;
975	} else {
976	/*
977	* General backslash substitution in comments isn't part
978	* of the formal spec, but test parse-15.47 and history
979	* indicate that it has been the de facto rule. Don't
980	* change it now.
981	*/
982
983	TclParseBackslash(p, numBytes, &scanned, NULL);
984	p += scanned;
985	numBytes -= scanned;
986	}
987	} else {
988	p++;
989	numBytes--;
990	if (p[-1] == '\n') {
991	break;
992	}
993	}
994	}
995	parsePtr->commentSize = p - parsePtr->commentStart;
996	}
997	return (p - src);
998	}
999
1000	/*
1001	*----------------------------------------------------------------------
1002	*
1003	* ParseTokens --
1004	*
1005	* This function forms the heart of the Tcl parser. It parses one or more
1006	* tokens from a string, up to a termination point specified by the
1007	* caller. This function is used to parse unquoted command words (those
1008	* not in quotes or braces), words in quotes, and array indices for
1009	* variables. No more than numBytes bytes will be scanned.
1010	*
1011	* Results:
1012	* Tokens are added to parsePtr and parsePtr->term is filled in with the
1013	* address of the character that terminated the parse (the first one
1014	* whose CHAR_TYPE matched mask or the character at parsePtr->end). The
1015	* return value is TCL_OK if the parse completed successfully and
1016	* TCL_ERROR otherwise. If a parse error occurs and parsePtr->interp is
1017	* not NULL, then an error message is left in the interpreter's result.
1018	*
1019	* Side effects:
1020	* None.
1021	*
1022	*----------------------------------------------------------------------
1023	*/
1024
1025	static int
1026	ParseTokens(
1027	register const char src, / First character to parse. */
1028	register int numBytes, /* Max number of bytes to scan. */
1029	int mask, /* Specifies when to stop parsing. The parse
1030	* stops at the first unquoted character whose
1031	* CHAR_TYPE contains any of the bits in
1032	* mask. */
1033	int flags, /* OR-ed bits indicating what substitutions to
1034	* perform: TCL_SUBST_COMMANDS,
1035	* TCL_SUBST_VARIABLES, and
1036	* TCL_SUBST_BACKSLASHES */
1037	Tcl_Parse parsePtr) / Information about parse in progress.
1038	* Updated with additional tokens and
1039	* termination information. */
1040	{
1041	char type;
1042	int originalTokens;
1043	int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
1044	int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
1045	int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
1046	Tcl_Token *tokenPtr;
1047
1048	/*
1049	* Each iteration through the following loop adds one token of type
1050	* TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE
1051	* to parsePtr. For TCL_TOKEN_VARIABLE tokens, additional tokens are added
1052	* for the parsed variable name.
1053	*/
1054
1055	originalTokens = parsePtr->numTokens;
1056	while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
1057	TclGrowParseTokenArray(parsePtr, 1);
1058	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1059	tokenPtr->start = src;
1060	tokenPtr->numComponents = 0;
1061
1062	if ((type & TYPE_SUBS) == 0) {
1063	/*
1064	* This is a simple range of characters. Scan to find the end of
1065	* the range.
1066	*/
1067
1068	while ((++src, --numBytes)
1069	&& !(CHAR_TYPE(*src) & (mask \| TYPE_SUBS))) {
1070	/* empty loop */
1071	}
1072	tokenPtr->type = TCL_TOKEN_TEXT;
1073	tokenPtr->size = src - tokenPtr->start;
1074	parsePtr->numTokens++;
1075	} else if (*src == '$') {
1076	int varToken;
1077
1078	if (noSubstVars) {
1079	tokenPtr->type = TCL_TOKEN_TEXT;
1080	tokenPtr->size = 1;
1081	parsePtr->numTokens++;
1082	src++;
1083	numBytes--;
1084	continue;
1085	}
1086
1087	/*
1088	* This is a variable reference. Call Tcl_ParseVarName to do all
1089	* the dirty work of parsing the name.
1090	*/
1091
1092	varToken = parsePtr->numTokens;
1093	if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr,
1094	1) != TCL_OK) {
1095	return TCL_ERROR;
1096	}
1097	src += parsePtr->tokenPtr[varToken].size;
1098	numBytes -= parsePtr->tokenPtr[varToken].size;
1099	} else if (*src == '[') {
1100	Tcl_Parse *nestedPtr;
1101
1102	if (noSubstCmds) {
1103	tokenPtr->type = TCL_TOKEN_TEXT;
1104	tokenPtr->size = 1;
1105	parsePtr->numTokens++;
1106	src++;
1107	numBytes--;
1108	continue;
1109	}
1110
1111	/*
1112	* Command substitution. Call Tcl_ParseCommand recursively (and
1113	* repeatedly) to parse the nested command(s), then throw away the
1114	* parse information.
1115	*/
1116
1117	src++;
1118	numBytes--;
1119	nestedPtr = (Tcl_Parse *)
1120	TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
1121	while (1) {
1122	if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
1123	nestedPtr) != TCL_OK) {
1124	parsePtr->errorType = nestedPtr->errorType;
1125	parsePtr->term = nestedPtr->term;
1126	parsePtr->incomplete = nestedPtr->incomplete;
1127	TclStackFree(parsePtr->interp, nestedPtr);
1128	return TCL_ERROR;
1129	}
1130	src = nestedPtr->commandStart + nestedPtr->commandSize;
1131	numBytes = parsePtr->end - src;
1132	Tcl_FreeParse(nestedPtr);
1133
1134	/*
1135	* Check for the closing ']' that ends the command
1136	* substitution. It must have been the last character of the
1137	* parsed command.
1138	*/
1139
1140	if ((nestedPtr->term < parsePtr->end)
1141	&& (*(nestedPtr->term) == ']')
1142	&& !(nestedPtr->incomplete)) {
1143	break;
1144	}
1145	if (numBytes == 0) {
1146	if (parsePtr->interp != NULL) {
1147	Tcl_SetResult(parsePtr->interp,
1148	"missing close-bracket", TCL_STATIC);
1149	}
1150	parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
1151	parsePtr->term = tokenPtr->start;
1152	parsePtr->incomplete = 1;
1153	TclStackFree(parsePtr->interp, nestedPtr);
1154	return TCL_ERROR;
1155	}
1156	}
1157	TclStackFree(parsePtr->interp, nestedPtr);
1158	tokenPtr->type = TCL_TOKEN_COMMAND;
1159	tokenPtr->size = src - tokenPtr->start;
1160	parsePtr->numTokens++;
1161	} else if (*src == '\\') {
1162	if (noSubstBS) {
1163	tokenPtr->type = TCL_TOKEN_TEXT;
1164	tokenPtr->size = 1;
1165	parsePtr->numTokens++;
1166	src++;
1167	numBytes--;
1168	continue;
1169	}
1170
1171	/*
1172	* Backslash substitution.
1173	*/
1174
1175	TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
1176
1177	if (tokenPtr->size == 1) {
1178	/*
1179	* Just a backslash, due to end of string.
1180	*/
1181
1182	tokenPtr->type = TCL_TOKEN_TEXT;
1183	parsePtr->numTokens++;
1184	src++;
1185	numBytes--;
1186	continue;
1187	}
1188
1189	if (src[1] == '\n') {
1190	if (numBytes == 2) {
1191	parsePtr->incomplete = 1;
1192	}
1193
1194	/*
1195	* Note: backslash-newline is special in that it is treated
1196	* the same as a space character would be. This means that it
1197	* could terminate the token.
1198	*/
1199
1200	if (mask & TYPE_SPACE) {
1201	if (parsePtr->numTokens == originalTokens) {
1202	goto finishToken;
1203	}
1204	break;
1205	}
1206	}
1207
1208	tokenPtr->type = TCL_TOKEN_BS;
1209	parsePtr->numTokens++;
1210	src += tokenPtr->size;
1211	numBytes -= tokenPtr->size;
1212	} else if (*src == 0) {
1213	tokenPtr->type = TCL_TOKEN_TEXT;
1214	tokenPtr->size = 1;
1215	parsePtr->numTokens++;
1216	src++;
1217	numBytes--;
1218	} else {
1219	Tcl_Panic("ParseTokens encountered unknown character");
1220	}
1221	}
1222	if (parsePtr->numTokens == originalTokens) {
1223	/*
1224	* There was nothing in this range of text. Add an empty token for the
1225	* empty range, so that there is always at least one token added.
1226	*/
1227
1228	TclGrowParseTokenArray(parsePtr, 1);
1229	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1230	tokenPtr->start = src;
1231	tokenPtr->numComponents = 0;
1232
1233	finishToken:
1234	tokenPtr->type = TCL_TOKEN_TEXT;
1235	tokenPtr->size = 0;
1236	parsePtr->numTokens++;
1237	}
1238	parsePtr->term = src;
1239	return TCL_OK;
1240	}
1241
1242	/*
1243	*----------------------------------------------------------------------
1244	*
1245	* Tcl_FreeParse --
1246	*
1247	* This function is invoked to free any dynamic storage that may have
1248	* been allocated by a previous call to Tcl_ParseCommand.
1249	*
1250	* Results:
1251	* None.
1252	*
1253	* Side effects:
1254	* If there is any dynamically allocated memory in *parsePtr, it is
1255	* freed.
1256	*
1257	*----------------------------------------------------------------------
1258	*/
1259
1260	void
1261	Tcl_FreeParse(
1262	Tcl_Parse parsePtr) / Structure that was filled in by a previous
1263	* call to Tcl_ParseCommand. */
1264	{
1265	if (parsePtr->tokenPtr != parsePtr->staticTokens) {
1266	ckfree((char *) parsePtr->tokenPtr);
1267	parsePtr->tokenPtr = parsePtr->staticTokens;
1268	}
1269	}
1270
1271	/*
1272	*----------------------------------------------------------------------
1273	*
1274	* Tcl_ParseVarName --
1275	*
1276	* Given a string starting with a $ sign, parse off a variable name and
1277	* return information about the parse. No more than numBytes bytes will
1278	* be scanned.
1279	*
1280	* Results:
1281	* The return value is TCL_OK if the command was parsed successfully and
1282	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
1283	* error message is left in its result. On a successful return, tokenPtr
1284	* and numTokens fields of parsePtr are filled in with information about
1285	* the variable name that was parsed. The "size" field of the first new
1286	* token gives the total number of bytes in the variable name. Other
1287	* fields in parsePtr are undefined.
1288	*
1289	* Side effects:
1290	* If there is insufficient space in parsePtr to hold all the information
1291	* about the command, then additional space is malloc-ed. If the function
1292	* returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
1293	* release any additional space that was allocated.
1294	*
1295	*----------------------------------------------------------------------
1296	*/
1297
1298	int
1299	Tcl_ParseVarName(
1300	Tcl_Interp interp, / Interpreter to use for error reporting; if
1301	* NULL, then no error message is provided. */
1302	const char start, / Start of variable substitution string.
1303	* First character must be "$". */
1304	register int numBytes, /* Total number of bytes in string. If < 0,
1305	* the string consists of all bytes up to the
1306	* first null character. */
1307	Tcl_Parse parsePtr, / Structure to fill in with information about
1308	* the variable name. */
1309	int append) /* Non-zero means append tokens to existing
1310	* information in parsePtr; zero means ignore
1311	* existing tokens in parsePtr and
1312	* reinitialize it. */
1313	{
1314	Tcl_Token *tokenPtr;
1315	register const char *src;
1316	unsigned char c;
1317	int varIndex, offset;
1318	Tcl_UniChar ch;
1319	unsigned array;
1320
1321	if ((numBytes == 0) \|\| (start == NULL)) {
1322	return TCL_ERROR;
1323	}
1324	if (numBytes < 0) {
1325	numBytes = strlen(start);
1326	}
1327
1328	if (!append) {
1329	TclParseInit(interp, start, numBytes, parsePtr);
1330	}
1331
1332	/*
1333	* Generate one token for the variable, an additional token for the name,
1334	* plus any number of additional tokens for the index, if there is one.
1335	*/
1336
1337	src = start;
1338	TclGrowParseTokenArray(parsePtr, 2);
1339	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1340	tokenPtr->type = TCL_TOKEN_VARIABLE;
1341	tokenPtr->start = src;
1342	varIndex = parsePtr->numTokens;
1343	parsePtr->numTokens++;
1344	tokenPtr++;
1345	src++;
1346	numBytes--;
1347	if (numBytes == 0) {
1348	goto justADollarSign;
1349	}
1350	tokenPtr->type = TCL_TOKEN_TEXT;
1351	tokenPtr->start = src;
1352	tokenPtr->numComponents = 0;
1353
1354	/*
1355	* The name of the variable can have three forms:
1356	* 1. The $ sign is followed by an open curly brace. Then the variable
1357	* name is everything up to the next close curly brace, and the
1358	* variable is a scalar variable.
1359	* 2. The $ sign is not followed by an open curly brace. Then the variable
1360	* name is everything up to the next character that isn't a letter,
1361	* digit, or underscore. :: sequences are also considered part of the
1362	* variable name, in order to support namespaces. If the following
1363	* character is an open parenthesis, then the information between
1364	* parentheses is the array element name.
1365	* 3. The $ sign is followed by something that isn't a letter, digit, or
1366	* underscore: in this case, there is no variable name and the token is
1367	* just "$".
1368	*/
1369
1370	if (*src == '{') {
1371	src++;
1372	numBytes--;
1373	tokenPtr->type = TCL_TOKEN_TEXT;
1374	tokenPtr->start = src;
1375	tokenPtr->numComponents = 0;
1376
1377	while (numBytes && (*src != '}')) {
1378	numBytes--;
1379	src++;
1380	}
1381	if (numBytes == 0) {
1382	if (parsePtr->interp != NULL) {
1383	Tcl_SetResult(parsePtr->interp,
1384	"missing close-brace for variable name", TCL_STATIC);
1385	}
1386	parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
1387	parsePtr->term = tokenPtr->start-1;
1388	parsePtr->incomplete = 1;
1389	goto error;
1390	}
1391	tokenPtr->size = src - tokenPtr->start;
1392	tokenPtr[-1].size = src - tokenPtr[-1].start;
1393	parsePtr->numTokens++;
1394	src++;
1395	} else {
1396	tokenPtr->type = TCL_TOKEN_TEXT;
1397	tokenPtr->start = src;
1398	tokenPtr->numComponents = 0;
1399
1400	while (numBytes) {
1401	if (Tcl_UtfCharComplete(src, numBytes)) {
1402	offset = Tcl_UtfToUniChar(src, &ch);
1403	} else {
1404	char utfBytes[TCL_UTF_MAX];
1405
1406	memcpy(utfBytes, src, (size_t) numBytes);
1407	utfBytes[numBytes] = '\0';
1408	offset = Tcl_UtfToUniChar(utfBytes, &ch);
1409	}
1410	c = UCHAR(ch);
1411	if (isalnum(c) \|\| (c == '_')) { /* INTL: ISO only, UCHAR. */
1412	src += offset;
1413	numBytes -= offset;
1414	continue;
1415	}
1416	if ((c == ':') && (numBytes != 1) && (src[1] == ':')) {
1417	src += 2;
1418	numBytes -= 2;
1419	while (numBytes && (*src == ':')) {
1420	src++;
1421	numBytes--;
1422	}
1423	continue;
1424	}
1425	break;
1426	}
1427
1428	/*
1429	* Support for empty array names here.
1430	*/
1431
1432	array = (numBytes && (*src == '('));
1433	tokenPtr->size = src - tokenPtr->start;
1434	if ((tokenPtr->size == 0) && !array) {
1435	goto justADollarSign;
1436	}
1437	parsePtr->numTokens++;
1438	if (array) {
1439	/*
1440	* This is a reference to an array element. Call ParseTokens
1441	* recursively to parse the element name, since it could contain
1442	* any number of substitutions.
1443	*/
1444
1445	if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN,
1446	TCL_SUBST_ALL, parsePtr)) {
1447	goto error;
1448	}
1449	if ((parsePtr->term == src+numBytes) \|\| (*parsePtr->term != ')')){
1450	if (parsePtr->interp != NULL) {
1451	Tcl_SetResult(parsePtr->interp, "missing )",
1452	TCL_STATIC);
1453	}
1454	parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
1455	parsePtr->term = src;
1456	parsePtr->incomplete = 1;
1457	goto error;
1458	}
1459	src = parsePtr->term + 1;
1460	}
1461	}
1462	tokenPtr = &parsePtr->tokenPtr[varIndex];
1463	tokenPtr->size = src - tokenPtr->start;
1464	tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
1465	return TCL_OK;
1466
1467	/*
1468	* The dollar sign isn't followed by a variable name. Replace the
1469	* TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar
1470	* sign.
1471	*/
1472
1473	justADollarSign:
1474	tokenPtr = &parsePtr->tokenPtr[varIndex];
1475	tokenPtr->type = TCL_TOKEN_TEXT;
1476	tokenPtr->size = 1;
1477	tokenPtr->numComponents = 0;
1478	return TCL_OK;
1479
1480	error:
1481	Tcl_FreeParse(parsePtr);
1482	return TCL_ERROR;
1483	}
1484
1485	/*
1486	*----------------------------------------------------------------------
1487	*
1488	* Tcl_ParseVar --
1489	*
1490	* Given a string starting with a $ sign, parse off a variable name and
1491	* return its value.
1492	*
1493	* Results:
1494	* The return value is the contents of the variable given by the leading
1495	* characters of string. If termPtr isn't NULL, *termPtr gets filled in
1496	* with the address of the character just after the last one in the
1497	* variable specifier. If the variable doesn't exist, then the return
1498	* value is NULL and an error message will be left in interp's result.
1499	*
1500	* Side effects:
1501	* None.
1502	*
1503	*----------------------------------------------------------------------
1504	*/
1505
1506	const char *
1507	Tcl_ParseVar(
1508	Tcl_Interp interp, / Context for looking up variable. */
1509	register const char start, / Start of variable substitution. First
1510	* character must be "$". */
1511	const char *termPtr) / If non-NULL, points to word to fill in with
1512	* character just after last one in the
1513	* variable specifier. */
1514	{
1515	register Tcl_Obj *objPtr;
1516	int code;
1517	Tcl_Parse parsePtr = (Tcl_Parse )
1518	TclStackAlloc(interp, sizeof(Tcl_Parse));
1519
1520	if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
1521	TclStackFree(interp, parsePtr);
1522	return NULL;
1523	}
1524
1525	if (termPtr != NULL) {
1526	*termPtr = start + parsePtr->tokenPtr->size;
1527	}
1528	if (parsePtr->numTokens == 1) {
1529	/*
1530	* There isn't a variable name after all: the $ is just a $.
1531	*/
1532
1533	TclStackFree(interp, parsePtr);
1534	return "$";
1535	}
1536
1537	code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
1538	NULL, 1);
1539	TclStackFree(interp, parsePtr);
1540	if (code != TCL_OK) {
1541	return NULL;
1542	}
1543	objPtr = Tcl_GetObjResult(interp);
1544
1545	/*
1546	* At this point we should have an object containing the value of a
1547	* variable. Just return the string from that object.
1548	*
1549	* This should have returned the object for the user to manage, but
1550	* instead we have some weak reference to the string value in the object,
1551	* which is why we make sure the object exists after resetting the result.
1552	* This isn't ideal, but it's the best we can do with the current
1553	* documented interface. -- hobbs
1554	*/
1555
1556	if (!Tcl_IsShared(objPtr)) {
1557	Tcl_IncrRefCount(objPtr);
1558	}
1559	Tcl_ResetResult(interp);
1560	return TclGetString(objPtr);
1561	}
1562
1563	/*
1564	*----------------------------------------------------------------------
1565	*
1566	* Tcl_ParseBraces --
1567	*
1568	* Given a string in braces such as a Tcl command argument or a string
1569	* value in a Tcl expression, this function parses the string and returns
1570	* information about the parse. No more than numBytes bytes will be
1571	* scanned.
1572	*
1573	* Results:
1574	* The return value is TCL_OK if the string was parsed successfully and
1575	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
1576	* error message is left in its result. On a successful return, tokenPtr
1577	* and numTokens fields of parsePtr are filled in with information about
1578	* the string that was parsed. Other fields in parsePtr are undefined.
1579	* termPtr is set to point to the character just after the last one in
1580	* the braced string.
1581	*
1582	* Side effects:
1583	* If there is insufficient space in parsePtr to hold all the information
1584	* about the command, then additional space is malloc-ed. If the function
1585	* returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
1586	* release any additional space that was allocated.
1587	*
1588	*----------------------------------------------------------------------
1589	*/
1590
1591	int
1592	Tcl_ParseBraces(
1593	Tcl_Interp interp, / Interpreter to use for error reporting; if
1594	* NULL, then no error message is provided. */
1595	const char start, / Start of string enclosed in braces. The
1596	* first character must be {'. */
1597	register int numBytes, /* Total number of bytes in string. If < 0,
1598	* the string consists of all bytes up to the
1599	* first null character. */
1600	register Tcl_Parse *parsePtr,
1601	/* Structure to fill in with information about
1602	* the string. */
1603	int append, /* Non-zero means append tokens to existing
1604	* information in parsePtr; zero means ignore
1605	* existing tokens in parsePtr and
1606	* reinitialize it. */
1607	const char *termPtr) / If non-NULL, points to word in which to
1608	* store a pointer to the character just after
1609	* the terminating '}' if the parse was
1610	* successful. */
1611	{
1612	Tcl_Token *tokenPtr;
1613	register const char *src;
1614	int startIndex, level, length;
1615
1616	if ((numBytes == 0) \|\| (start == NULL)) {
1617	return TCL_ERROR;
1618	}
1619	if (numBytes < 0) {
1620	numBytes = strlen(start);
1621	}
1622
1623	if (!append) {
1624	TclParseInit(interp, start, numBytes, parsePtr);
1625	}
1626
1627	src = start;
1628	startIndex = parsePtr->numTokens;
1629
1630	TclGrowParseTokenArray(parsePtr, 1);
1631	tokenPtr = &parsePtr->tokenPtr[startIndex];
1632	tokenPtr->type = TCL_TOKEN_TEXT;
1633	tokenPtr->start = src+1;
1634	tokenPtr->numComponents = 0;
1635	level = 1;
1636	while (1) {
1637	while (++src, --numBytes) {
1638	if (CHAR_TYPE(*src) != TYPE_NORMAL) {
1639	break;
1640	}
1641	}
1642	if (numBytes == 0) {
1643	goto missingBraceError;
1644	}
1645
1646	switch (*src) {
1647	case '{':
1648	level++;
1649	break;
1650	case '}':
1651	if (--level == 0) {
1652	/*
1653	* Decide if we need to finish emitting a partially-finished
1654	* token. There are 3 cases:
1655	* {abc \newline xyz} or {xyz}
1656	* - finish emitting "xyz" token
1657	* {abc \newline}
1658	* - don't emit token after \newline
1659	* {} - finish emitting zero-sized token
1660	*
1661	* The last case ensures that there is a token (even if empty)
1662	* that describes the braced string.
1663	*/
1664
1665	if ((src != tokenPtr->start)
1666	\|\| (parsePtr->numTokens == startIndex)) {
1667	tokenPtr->size = (src - tokenPtr->start);
1668	parsePtr->numTokens++;
1669	}
1670	if (termPtr != NULL) {
1671	*termPtr = src+1;
1672	}
1673	return TCL_OK;
1674	}
1675	break;
1676	case '\\':
1677	TclParseBackslash(src, numBytes, &length, NULL);
1678	if ((length > 1) && (src[1] == '\n')) {
1679	/*
1680	* A backslash-newline sequence must be collapsed, even inside
1681	* braces, so we have to split the word into multiple tokens
1682	* so that the backslash-newline can be represented
1683	* explicitly.
1684	*/
1685
1686	if (numBytes == 2) {
1687	parsePtr->incomplete = 1;
1688	}
1689	tokenPtr->size = (src - tokenPtr->start);
1690	if (tokenPtr->size != 0) {
1691	parsePtr->numTokens++;
1692	}
1693	TclGrowParseTokenArray(parsePtr, 2);
1694	tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1695	tokenPtr->type = TCL_TOKEN_BS;
1696	tokenPtr->start = src;
1697	tokenPtr->size = length;
1698	tokenPtr->numComponents = 0;
1699	parsePtr->numTokens++;
1700
1701	src += length - 1;
1702	numBytes -= length - 1;
1703	tokenPtr++;
1704	tokenPtr->type = TCL_TOKEN_TEXT;
1705	tokenPtr->start = src + 1;
1706	tokenPtr->numComponents = 0;
1707	} else {
1708	src += length - 1;
1709	numBytes -= length - 1;
1710	}
1711	break;
1712	}
1713	}
1714
1715	missingBraceError:
1716	parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
1717	parsePtr->term = start;
1718	parsePtr->incomplete = 1;
1719	if (parsePtr->interp == NULL) {
1720	/*
1721	* Skip straight to the exit code since we have no interpreter to put
1722	* error message in.
1723	*/
1724
1725	goto error;
1726	}
1727
1728	Tcl_SetResult(parsePtr->interp, "missing close-brace", TCL_STATIC);
1729
1730	/*
1731	* Guess if the problem is due to comments by searching the source string
1732	* for a possible open brace within the context of a comment. Since we
1733	* aren't performing a full Tcl parse, just look for an open brace
1734	* preceded by a '<whitespace>#' on the same line.
1735	*/
1736
1737	{
1738	register int openBrace = 0;
1739
1740	while (--src > start) {
1741	switch (*src) {
1742	case '{':
1743	openBrace = 1;
1744	break;
1745	case '\n':
1746	openBrace = 0;
1747	break;
1748	case '#' :
1749	if (openBrace && isspace(UCHAR(src[-1]))) {
1750	Tcl_AppendResult(parsePtr->interp,
1751	": possible unbalanced brace in comment", NULL);
1752	goto error;
1753	}
1754	break;
1755	}
1756	}
1757	}
1758
1759	error:
1760	Tcl_FreeParse(parsePtr);
1761	return TCL_ERROR;
1762	}
1763
1764	/*
1765	*----------------------------------------------------------------------
1766	*
1767	* Tcl_ParseQuotedString --
1768	*
1769	* Given a double-quoted string such as a quoted Tcl command argument or
1770	* a quoted value in a Tcl expression, this function parses the string
1771	* and returns information about the parse. No more than numBytes bytes
1772	* will be scanned.
1773	*
1774	* Results:
1775	* The return value is TCL_OK if the string was parsed successfully and
1776	* TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an
1777	* error message is left in its result. On a successful return, tokenPtr
1778	* and numTokens fields of parsePtr are filled in with information about
1779	* the string that was parsed. Other fields in parsePtr are undefined.
1780	* termPtr is set to point to the character just after the quoted
1781	* string's terminating close-quote.
1782	*
1783	* Side effects:
1784	* If there is insufficient space in parsePtr to hold all the information
1785	* about the command, then additional space is malloc-ed. If the function
1786	* returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
1787	* release any additional space that was allocated.
1788	*
1789	*----------------------------------------------------------------------
1790	*/
1791
1792	int
1793	Tcl_ParseQuotedString(
1794	Tcl_Interp interp, / Interpreter to use for error reporting; if
1795	* NULL, then no error message is provided. */
1796	const char start, / Start of the quoted string. The first
1797	* character must be '"'. */
1798	register int numBytes, /* Total number of bytes in string. If < 0,
1799	* the string consists of all bytes up to the
1800	* first null character. */
1801	register Tcl_Parse *parsePtr,
1802	/* Structure to fill in with information about
1803	* the string. */
1804	int append, /* Non-zero means append tokens to existing
1805	* information in parsePtr; zero means ignore
1806	* existing tokens in parsePtr and
1807	* reinitialize it. */
1808	const char *termPtr) / If non-NULL, points to word in which to
1809	* store a pointer to the character just after
1810	* the quoted string's terminating close-quote
1811	* if the parse succeeds. */
1812	{
1813	if ((numBytes == 0) \|\| (start == NULL)) {
1814	return TCL_ERROR;
1815	}
1816	if (numBytes < 0) {
1817	numBytes = strlen(start);
1818	}
1819
1820	if (!append) {
1821	TclParseInit(interp, start, numBytes, parsePtr);
1822	}
1823
1824	if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
1825	parsePtr)) {
1826	goto error;
1827	}
1828	if (*parsePtr->term != '"') {
1829	if (parsePtr->interp != NULL) {
1830	Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
1831	}
1832	parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
1833	parsePtr->term = start;
1834	parsePtr->incomplete = 1;
1835	goto error;
1836	}
1837	if (termPtr != NULL) {
1838	*termPtr = (parsePtr->term + 1);
1839	}
1840	return TCL_OK;
1841
1842	error:
1843	Tcl_FreeParse(parsePtr);
1844	return TCL_ERROR;
1845	}
1846
1847	/*
1848	*----------------------------------------------------------------------
1849	*
1850	* Tcl_SubstObj --
1851	*
1852	* This function performs the substitutions specified on the given string
1853	* as described in the user documentation for the "subst" Tcl command.
1854	*
1855	* Results:
1856	* A Tcl_Obj* containing the substituted string, or NULL to indicate that
1857	* an error occurred.
1858	*
1859	* Side effects:
1860	* See the user documentation.
1861	*
1862	*----------------------------------------------------------------------
1863	*/
1864
1865	Tcl_Obj *
1866	Tcl_SubstObj(
1867	Tcl_Interp interp, / Interpreter in which substitution occurs */
1868	Tcl_Obj objPtr, / The value to be substituted. */
1869	int flags) /* What substitutions to do. */
1870	{
1871	int length, tokensLeft, code;
1872	Tcl_Token *endTokenPtr;
1873	Tcl_Obj result, errMsg = NULL;
1874	CONST char *p = TclGetStringFromObj(objPtr, &length);
1875	Tcl_Parse parsePtr = (Tcl_Parse )
1876	TclStackAlloc(interp, sizeof(Tcl_Parse));
1877
1878	TclParseInit(interp, p, length, parsePtr);
1879
1880	/*
1881	* First parse the string rep of objPtr, as if it were enclosed as a
1882	* "-quoted word in a normal Tcl command. Honor flags that selectively
1883	* inhibit types of substitution.
1884	*/
1885
1886	if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, parsePtr)) {
1887	/*
1888	* There was a parse error. Save the error message for possible
1889	* reporting later.
1890	*/
1891
1892	errMsg = Tcl_GetObjResult(interp);
1893	Tcl_IncrRefCount(errMsg);
1894
1895	/*
1896	* We need to re-parse to get the portion of the string we can [subst]
1897	* before the parse error. Sadly, all the Tcl_Token's created by the
1898	* first parse attempt are gone, freed according to the public spec
1899	* for the Tcl_Parse* routines. The only clue we have is parse.term,
1900	* which points to either the unmatched opener, or to characters that
1901	* follow a close brace or close quote.
1902	*
1903	* Call ParseTokens again, working on the string up to parse.term.
1904	* Keep repeating until we get a good parse on a prefix.
1905	*/
1906
1907	do {
1908	parsePtr->numTokens = 0;
1909	parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
1910	parsePtr->end = parsePtr->term;
1911	parsePtr->incomplete = 0;
1912	parsePtr->errorType = TCL_PARSE_SUCCESS;
1913	} while (TCL_OK !=
1914	ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));
1915
1916	/*
1917	* The good parse will have to be followed by {, (, or [.
1918	*/
1919
1920	switch (*(parsePtr->term)) {
1921	case '{':
1922	/*
1923	* Parse error was a missing } in a ${varname} variable
1924	* substitution at the toplevel. We will subst everything up to
1925	* that broken variable substitution before reporting the parse
1926	* error. Substituting the leftover '$' will have no side-effects,
1927	* so the current token stream is fine.
1928	*/
1929	break;
1930
1931	case '(':
1932	/*
1933	* Parse error was during the parsing of the index part of an
1934	* array variable substitution at the toplevel.
1935	*/
1936
1937	if (*(parsePtr->term - 1) == '$') {
1938	/*
1939	* Special case where removing the array index left us with
1940	* just a dollar sign (array variable with name the empty
1941	* string as its name), instead of with a scalar variable
1942	* reference.
1943	*
1944	* As in the previous case, existing token stream is OK.
1945	*/
1946	} else {
1947	/*
1948	* The current parse includes a successful parse of a scalar
1949	* variable substitution where there should have been an array
1950	* variable substitution. We remove that mistaken part of the
1951	* parse before moving on. A scalar variable substitution is
1952	* two tokens.
1953	*/
1954
1955	Tcl_Token *varTokenPtr =
1956	parsePtr->tokenPtr + parsePtr->numTokens - 2;
1957
1958	if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
1959	Tcl_Panic("Tcl_SubstObj: programming error");
1960	}
1961	if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
1962	Tcl_Panic("Tcl_SubstObj: programming error");
1963	}
1964	parsePtr->numTokens -= 2;
1965	}
1966	break;
1967	case '[':
1968	/*
1969	* Parse error occurred during parsing of a toplevel command
1970	* substitution.
1971	*/
1972
1973	parsePtr->end = p + length;
1974	p = parsePtr->term + 1;
1975	length = parsePtr->end - p;
1976	if (length == 0) {
1977	/*
1978	* No commands, just an unmatched [. As in previous cases,
1979	* existing token stream is OK.
1980	*/
1981	} else {
1982	/*
1983	* We want to add the parsing of as many commands as we can
1984	* within that substitution until we reach the actual parse
1985	* error. We'll do additional parsing to determine what length
1986	* to claim for the final TCL_TOKEN_COMMAND token.
1987	*/
1988
1989	Tcl_Token *tokenPtr;
1990	const char *lastTerm = parsePtr->term;
1991	Tcl_Parse nestedPtr = (Tcl_Parse )
1992	TclStackAlloc(interp, sizeof(Tcl_Parse));
1993
1994	while (TCL_OK ==
1995	Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) {
1996	Tcl_FreeParse(nestedPtr);
1997	p = nestedPtr->term + (nestedPtr->term < nestedPtr->end);
1998	length = nestedPtr->end - p;
1999	if ((length == 0) && (nestedPtr->term == nestedPtr->end)) {
2000	/*
2001	* If we run out of string, blame the missing close
2002	* bracket on the last command, and do not evaluate it
2003	* during substitution.
2004	*/
2005
2006	break;
2007	}
2008	lastTerm = nestedPtr->term;
2009	}
2010	TclStackFree(interp, nestedPtr);
2011
2012	if (lastTerm == parsePtr->term) {
2013	/*
2014	* Parse error in first command. No commands to subst, add
2015	* no more tokens.
2016	*/
2017	break;
2018	}
2019
2020	/*
2021	* Create a command substitution token for whatever commands
2022	* got parsed.
2023	*/
2024
2025	TclGrowParseTokenArray(parsePtr, 1);
2026	tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]);
2027	tokenPtr->start = parsePtr->term;
2028	tokenPtr->numComponents = 0;
2029	tokenPtr->type = TCL_TOKEN_COMMAND;
2030	tokenPtr->size = lastTerm - tokenPtr->start + 1;
2031	parsePtr->numTokens++;
2032	}
2033	break;
2034
2035	default:
2036	Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]);
2037	}
2038	}
2039
2040	/*
2041	* Next, substitute the parsed tokens just as in normal Tcl evaluation.
2042	*/
2043
2044	endTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
2045	tokensLeft = parsePtr->numTokens;
2046	code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
2047	&tokensLeft, 1);
2048	if (code == TCL_OK) {
2049	Tcl_FreeParse(parsePtr);
2050	TclStackFree(interp, parsePtr);
2051	if (errMsg != NULL) {
2052	Tcl_SetObjResult(interp, errMsg);
2053	Tcl_DecrRefCount(errMsg);
2054	return NULL;
2055	}
2056	return Tcl_GetObjResult(interp);
2057	}
2058
2059	result = Tcl_NewObj();
2060	while (1) {
2061	switch (code) {
2062	case TCL_ERROR:
2063	Tcl_FreeParse(parsePtr);
2064	TclStackFree(interp, parsePtr);
2065	Tcl_DecrRefCount(result);
2066	if (errMsg != NULL) {
2067	Tcl_DecrRefCount(errMsg);
2068	}
2069	return NULL;
2070	case TCL_BREAK:
2071	tokensLeft = 0; /* Halt substitution */
2072	default:
2073	Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp));
2074	}
2075
2076	if (tokensLeft == 0) {
2077	Tcl_FreeParse(parsePtr);
2078	TclStackFree(interp, parsePtr);
2079	if (errMsg != NULL) {
2080	if (code != TCL_BREAK) {
2081	Tcl_DecrRefCount(result);
2082	Tcl_SetObjResult(interp, errMsg);
2083	Tcl_DecrRefCount(errMsg);
2084	return NULL;
2085	}
2086	Tcl_DecrRefCount(errMsg);
2087	}
2088	return result;
2089	}
2090
2091	code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft,
2092	&tokensLeft, 1);
2093	}
2094	}
2095
2096	/*
2097	*----------------------------------------------------------------------
2098	*
2099	* TclSubstTokens --
2100	*
2101	* Accepts an array of count Tcl_Token's, and creates a result value in
2102	* the interp from concatenating the results of performing Tcl
2103	* substitution on each Tcl_Token. Substitution is interrupted if any
2104	* non-TCL_OK completion code arises.
2105	*
2106	* Results:
2107	* The return value is a standard Tcl completion code. The result in
2108	* interp is the substituted value, or an error message if TCL_ERROR is
2109	* returned. If tokensLeftPtr is not NULL, then it points to an int where
2110	* the number of tokens remaining to be processed is written.
2111	*
2112	* Side effects:
2113	* Can be anything, depending on the types of substitution done.
2114	*
2115	*----------------------------------------------------------------------
2116	*/
2117
2118	int
2119	TclSubstTokens(
2120	Tcl_Interp interp, / Interpreter in which to lookup variables,
2121	* execute nested commands, and report
2122	* errors. */
2123	Tcl_Token tokenPtr, / Pointer to first in an array of tokens to
2124	* evaluate and concatenate. */
2125	int count, /* Number of tokens to consider at tokenPtr.
2126	* Must be at least 1. */
2127	int tokensLeftPtr, / If not NULL, points to memory where an
2128	* integer representing the number of tokens
2129	* left to be substituted will be written */
2130	int line) /* The line the script starts on. */
2131	{
2132	Tcl_Obj *result;
2133	int code = TCL_OK;
2134
2135	/*
2136	* Each pass through this loop will substitute one token, and its
2137	* components, if any. The only thing tricky here is that we go to some
2138	* effort to pass Tcl_Obj's through untouched, to avoid string copying and
2139	* Tcl_Obj creation if possible, to aid performance and limit shimmering.
2140	*
2141	* Further optimization opportunities might be to check for the equivalent
2142	* of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
2143	*/
2144
2145	result = NULL;
2146	for (; count>0 && code==TCL_OK ; count--, tokenPtr++) {
2147	Tcl_Obj *appendObj = NULL;
2148	const char *append = NULL;
2149	int appendByteLength = 0;
2150	char utfCharBytes[TCL_UTF_MAX];
2151
2152	switch (tokenPtr->type) {
2153	case TCL_TOKEN_TEXT:
2154	append = tokenPtr->start;
2155	appendByteLength = tokenPtr->size;
2156	break;
2157
2158	case TCL_TOKEN_BS:
2159	appendByteLength = Tcl_UtfBackslash(tokenPtr->start, NULL,
2160	utfCharBytes);
2161	append = utfCharBytes;
2162	break;
2163
2164	case TCL_TOKEN_COMMAND: {
2165	Interp iPtr = (Interp ) interp;
2166
2167	iPtr->numLevels++;
2168	code = TclInterpReady(interp);
2169	if (code == TCL_OK) {
2170	/* TIP #280: Transfer line information to nested command */
2171	code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
2172	0, line);
2173	}
2174	iPtr->numLevels--;
2175	appendObj = Tcl_GetObjResult(interp);
2176	break;
2177	}
2178
2179	case TCL_TOKEN_VARIABLE: {
2180	Tcl_Obj *arrayIndex = NULL;
2181	Tcl_Obj *varName = NULL;
2182
2183	if (tokenPtr->numComponents > 1) {
2184	/*
2185	* Subst the index part of an array variable reference.
2186	*/
2187
2188	code = TclSubstTokens(interp, tokenPtr+2,
2189	tokenPtr->numComponents - 1, NULL, line);
2190	arrayIndex = Tcl_GetObjResult(interp);
2191	Tcl_IncrRefCount(arrayIndex);
2192	}
2193
2194	if (code == TCL_OK) {
2195	varName = Tcl_NewStringObj(tokenPtr[1].start,
2196	tokenPtr[1].size);
2197	appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex,
2198	TCL_LEAVE_ERR_MSG);
2199	Tcl_DecrRefCount(varName);
2200	if (appendObj == NULL) {
2201	code = TCL_ERROR;
2202	}
2203	}
2204
2205	switch (code) {
2206	case TCL_OK: /* Got value */
2207	case TCL_ERROR: /* Already have error message */
2208	case TCL_BREAK: /* Will not substitute anyway */
2209	case TCL_CONTINUE: /* Will not substitute anyway */
2210	break;
2211	default:
2212	/*
2213	* All other return codes, we will subst the result from the
2214	* code-throwing evaluation.
2215	*/
2216
2217	appendObj = Tcl_GetObjResult(interp);
2218	}
2219
2220	if (arrayIndex != NULL) {
2221	Tcl_DecrRefCount(arrayIndex);
2222	}
2223	count -= tokenPtr->numComponents;
2224	tokenPtr += tokenPtr->numComponents;
2225	break;
2226	}
2227
2228	default:
2229	Tcl_Panic("unexpected token type in TclSubstTokens: %d",
2230	tokenPtr->type);
2231	}
2232
2233	if ((code == TCL_BREAK) \|\| (code == TCL_CONTINUE)) {
2234	/*
2235	* Inhibit substitution.
2236	*/
2237	continue;
2238	}
2239
2240	if (result == NULL) {
2241	/*
2242	* First pass through. If we have a Tcl_Obj, just use it. If not,
2243	* create one from our string.
2244	*/
2245
2246	if (appendObj != NULL) {
2247	result = appendObj;
2248	} else {
2249	result = Tcl_NewStringObj(append, appendByteLength);
2250	}
2251	Tcl_IncrRefCount(result);
2252	} else {
2253	/*
2254	* Subsequent passes. Append to result.
2255	*/
2256
2257	if (Tcl_IsShared(result)) {
2258	Tcl_DecrRefCount(result);
2259	result = Tcl_DuplicateObj(result);
2260	Tcl_IncrRefCount(result);
2261	}
2262	if (appendObj != NULL) {
2263	Tcl_AppendObjToObj(result, appendObj);
2264	} else {
2265	Tcl_AppendToObj(result, append, appendByteLength);
2266	}
2267	}
2268	}
2269
2270	if (code != TCL_ERROR) { /* Keep error message in result! */
2271	if (result != NULL) {
2272	Tcl_SetObjResult(interp, result);
2273	} else {
2274	Tcl_ResetResult(interp);
2275	}
2276	}
2277	if (tokensLeftPtr != NULL) {
2278	*tokensLeftPtr = count;
2279	}
2280	if (result != NULL) {
2281	Tcl_DecrRefCount(result);
2282	}
2283	return code;
2284	}
2285
2286	/*
2287	*----------------------------------------------------------------------
2288	*
2289	* CommandComplete --
2290	*
2291	* This function is shared by TclCommandComplete and
2292	* Tcl_ObjCommandComplete; it does all the real work of seeing whether a
2293	* script is complete
2294	*
2295	* Results:
2296	* 1 is returned if the script is complete, 0 if there are open
2297	* delimiters such as " or (. 1 is also returned if there is a parse
2298	* error in the script other than unmatched delimiters.
2299	*
2300	* Side effects:
2301	* None.
2302	*
2303	*----------------------------------------------------------------------
2304	*/
2305
2306	static inline int
2307	CommandComplete(
2308	const char script, / Script to check. */
2309	int numBytes) /* Number of bytes in script. */
2310	{
2311	Tcl_Parse parse;
2312	const char p, end;
2313	int result;
2314
2315	p = script;
2316	end = p + numBytes;
2317	while (Tcl_ParseCommand(NULL, p, end - p, 0, &parse) == TCL_OK) {
2318	p = parse.commandStart + parse.commandSize;
2319	if (p >= end) {
2320	break;
2321	}
2322	Tcl_FreeParse(&parse);
2323	}
2324	if (parse.incomplete) {
2325	result = 0;
2326	} else {
2327	result = 1;
2328	}
2329	Tcl_FreeParse(&parse);
2330	return result;
2331	}
2332
2333	/*
2334	*----------------------------------------------------------------------
2335	*
2336	* Tcl_CommandComplete --
2337	*
2338	* Given a partial or complete Tcl script, this function determines
2339	* whether the script is complete in the sense of having matched braces
2340	* and quotes and brackets.
2341	*
2342	* Results:
2343	* 1 is returned if the script is complete, 0 otherwise. 1 is also
2344	* returned if there is a parse error in the script other than unmatched
2345	* delimiters.
2346	*
2347	* Side effects:
2348	* None.
2349	*
2350	*----------------------------------------------------------------------
2351	*/
2352
2353	int
2354	Tcl_CommandComplete(
2355	const char script) / Script to check. */
2356	{
2357	return CommandComplete(script, (int) strlen(script));
2358	}
2359
2360	/*
2361	*----------------------------------------------------------------------
2362	*
2363	* TclObjCommandComplete --
2364	*
2365	* Given a partial or complete Tcl command in a Tcl object, this function
2366	* determines whether the command is complete in the sense of having
2367	* matched braces and quotes and brackets.
2368	*
2369	* Results:
2370	* 1 is returned if the command is complete, 0 otherwise.
2371	*
2372	* Side effects:
2373	* None.
2374	*
2375	*----------------------------------------------------------------------
2376	*/
2377
2378	int
2379	TclObjCommandComplete(
2380	Tcl_Obj objPtr) / Points to object holding script to
2381	* check. */
2382	{
2383	int length;
2384	const char *script = Tcl_GetStringFromObj(objPtr, &length);
2385
2386	return CommandComplete(script, length);
2387	}
2388
2389	/*
2390	*----------------------------------------------------------------------
2391	*
2392	* TclIsLocalScalar --
2393	*
2394	* Check to see if a given string is a legal scalar variable name with no
2395	* namespace qualifiers or substitutions.
2396	*
2397	* Results:
2398	* Returns 1 if the variable is a local scalar.
2399	*
2400	* Side effects:
2401	* None.
2402	*
2403	*----------------------------------------------------------------------
2404	*/
2405
2406	int
2407	TclIsLocalScalar(
2408	const char *src,
2409	int len)
2410	{
2411	const char *p;
2412	const char *lastChar = src + (len - 1);
2413
2414	for (p=src ; p<=lastChar ; p++) {
2415	if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
2416	(CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
2417	/*
2418	* TCL_COMMAND_END is returned for the last character of the
2419	* string. By this point we know it isn't an array or namespace
2420	* reference.
2421	*/
2422
2423	return 0;
2424	}
2425	if (*p == '(') {
2426	if (lastChar == ')') { / We have an array element */
2427	return 0;
2428	}
2429	} else if (*p == ':') {
2430	if ((p != lastChar) && (p+1) == ':') { / qualified name */
2431	return 0;
2432	}
2433	}
2434	}
2435
2436	return 1;
2437	}
2438
2439	/*
2440	* Local Variables:
2441	* mode: c
2442	* c-basic-offset: 4
2443	* fill-column: 78
2444	* End:
2445	*/

Note: See TracBrowser for help on using the repository browser.

Download in other formats: