Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

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

Last change on this file since 63 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
57static 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
174static inline int       CommandComplete(const char *script, int numBytes);
175static int              ParseComment(const char *src, int numBytes,
176                            Tcl_Parse *parsePtr);
177static int              ParseTokens(const char *src, int numBytes, int mask,
178                            int flags, Tcl_Parse *parsePtr);
179static 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
198void
199TclParseInit(
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
242int
243Tcl_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
621static int
622ParseWhiteSpace(
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
675int
676TclParseAllWhiteSpace(
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
715int
716TclParseHex(
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
770int
771TclParseBackslash(
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
943static int
944ParseComment(
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
1025static int
1026ParseTokens(
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
1260void
1261Tcl_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
1298int
1299Tcl_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
1506const char *
1507Tcl_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
1591int
1592Tcl_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
1792int
1793Tcl_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
1865Tcl_Obj *
1866Tcl_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
2118int
2119TclSubstTokens(
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
2306static inline int
2307CommandComplete(
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
2353int
2354Tcl_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
2378int
2379TclObjCommandComplete(
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
2406int
2407TclIsLocalScalar(
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.