/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclparse.c
ViewVC logotype

Annotation of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclparse.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 29 - (hide annotations) (download)
Sat Oct 8 07:08:47 2016 UTC (8 years ago) by dashley
Original Path: to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclparse.c
File MIME type: text/plain
File size: 71286 byte(s)
Directories relocated.
1 dashley 25 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclparse.c,v 1.1.1.1 2001/06/13 04:44:26 dtashley Exp $ */
2    
3     /*
4     * tclParse.c --
5     *
6     * This file contains procedures that parse Tcl scripts. They
7     * do so in a general-purpose fashion that can be used for many
8     * different purposes, including compilation, direct execution,
9     * code analysis, etc. This file also includes a few additional
10     * procedures such as Tcl_EvalObjv, Tcl_Eval, and Tcl_EvalEx, which
11     * allow scripts to be evaluated directly, without compiling.
12     *
13     * Copyright (c) 1997 Sun Microsystems, Inc.
14     * Copyright (c) 1998 by Scriptics Corporation.
15     *
16     * See the file "license.terms" for information on usage and redistribution
17     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
18     *
19     * RCS: @(#) $Id: tclparse.c,v 1.1.1.1 2001/06/13 04:44:26 dtashley Exp $
20     */
21    
22     #include "tclInt.h"
23     #include "tclPort.h"
24    
25     /*
26     * The following table provides parsing information about each possible
27     * 8-bit character. The table is designed to be referenced with either
28     * signed or unsigned characters, so it has 384 entries. The first 128
29     * entries correspond to negative character values, the next 256 correspond
30     * to positive character values. The last 128 entries are identical to the
31     * first 128. The table is always indexed with a 128-byte offset (the 128th
32     * entry corresponds to a character value of 0).
33     *
34     * The macro CHAR_TYPE is used to index into the table and return
35     * information about its character argument. The following return
36     * values are defined.
37     *
38     * TYPE_NORMAL - All characters that don't have special significance
39     * to the Tcl parser.
40     * TYPE_SPACE - The character is a whitespace character other
41     * than newline.
42     * TYPE_COMMAND_END - Character is newline or semicolon.
43     * TYPE_SUBS - Character begins a substitution or has other
44     * special meaning in ParseTokens: backslash, dollar
45     * sign, open bracket, or null.
46     * TYPE_QUOTE - Character is a double quote.
47     * TYPE_CLOSE_PAREN - Character is a right parenthesis.
48     * TYPE_CLOSE_BRACK - Character is a right square bracket.
49     * TYPE_BRACE - Character is a curly brace (either left or right).
50     */
51    
52     #define TYPE_NORMAL 0
53     #define TYPE_SPACE 0x1
54     #define TYPE_COMMAND_END 0x2
55     #define TYPE_SUBS 0x4
56     #define TYPE_QUOTE 0x8
57     #define TYPE_CLOSE_PAREN 0x10
58     #define TYPE_CLOSE_BRACK 0x20
59     #define TYPE_BRACE 0x40
60    
61     #define CHAR_TYPE(c) (typeTable+128)[(int)(c)]
62    
63     char typeTable[] = {
64     /*
65     * Negative character values, from -128 to -1:
66     */
67    
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     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
95     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
96     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
97     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
98     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
99     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
100    
101     /*
102     * Positive character values, from 0-127:
103     */
104    
105     TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
106     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
107     TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
108     TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
109     TYPE_NORMAL, TYPE_NORMAL, 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_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
114     TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
115     TYPE_NORMAL, TYPE_CLOSE_PAREN, 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_COMMAND_END,
120     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
121     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
122     TYPE_NORMAL, TYPE_NORMAL, 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_SUBS,
128     TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
129     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
130     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
131     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
132     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
133     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
134     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
135     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
136     TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
137    
138     /*
139     * Large unsigned character values, from 128-255:
140     */
141    
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     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
169     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
170     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
171     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
172     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
173     TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
174     };
175    
176     /*
177     * Prototypes for local procedures defined in this file:
178     */
179    
180     static int CommandComplete _ANSI_ARGS_((char *script,
181     int length));
182     static int ParseTokens _ANSI_ARGS_((char *src, int mask,
183     Tcl_Parse *parsePtr));
184     static int EvalObjv _ANSI_ARGS_((Tcl_Interp *interp, int objc,
185     Tcl_Obj *CONST objv[], char *command, int length,
186     int flags));
187    
188     /*
189     *----------------------------------------------------------------------
190     *
191     * Tcl_ParseCommand --
192     *
193     * Given a string, this procedure parses the first Tcl command
194     * in the string and returns information about the structure of
195     * the command.
196     *
197     * Results:
198     * The return value is TCL_OK if the command was parsed
199     * successfully and TCL_ERROR otherwise. If an error occurs
200     * and interp isn't NULL then an error message is left in
201     * its result. On a successful return, parsePtr is filled in
202     * with information about the command that was parsed.
203     *
204     * Side effects:
205     * If there is insufficient space in parsePtr to hold all the
206     * information about the command, then additional space is
207     * malloc-ed. If the procedure returns TCL_OK then the caller must
208     * eventually invoke Tcl_FreeParse to release any additional space
209     * that was allocated.
210     *
211     *----------------------------------------------------------------------
212     */
213    
214     int
215     Tcl_ParseCommand(interp, string, numBytes, nested, parsePtr)
216     Tcl_Interp *interp; /* Interpreter to use for error reporting;
217     * if NULL, then no error message is
218     * provided. */
219     char *string; /* First character of string containing
220     * one or more Tcl commands. The string
221     * must be in writable memory and must
222     * have one additional byte of space at
223     * string[length] where we can
224     * temporarily store a 0 sentinel
225     * character. */
226     int numBytes; /* Total number of bytes in string. If < 0,
227     * the script consists of all bytes up to
228     * the first null character. */
229     int nested; /* Non-zero means this is a nested command:
230     * close bracket should be considered
231     * a command terminator. If zero, then close
232     * bracket has no special meaning. */
233     register Tcl_Parse *parsePtr;
234     /* Structure to fill in with information
235     * about the parsed command; any previous
236     * information in the structure is
237     * ignored. */
238     {
239     register char *src; /* Points to current character
240     * in the command. */
241     int type; /* Result returned by CHAR_TYPE(*src). */
242     Tcl_Token *tokenPtr; /* Pointer to token being filled in. */
243     int wordIndex; /* Index of word token for current word. */
244     char utfBytes[TCL_UTF_MAX]; /* Holds result of backslash substitution. */
245     int terminators; /* CHAR_TYPE bits that indicate the end
246     * of a command. */
247     char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
248     * point to char after terminating one. */
249     int length, savedChar;
250    
251    
252     if (numBytes < 0) {
253     numBytes = (string? strlen(string) : 0);
254     }
255     parsePtr->commentStart = NULL;
256     parsePtr->commentSize = 0;
257     parsePtr->commandStart = NULL;
258     parsePtr->commandSize = 0;
259     parsePtr->numWords = 0;
260     parsePtr->tokenPtr = parsePtr->staticTokens;
261     parsePtr->numTokens = 0;
262     parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
263     parsePtr->string = string;
264     parsePtr->end = string + numBytes;
265     parsePtr->term = parsePtr->end;
266     parsePtr->interp = interp;
267     parsePtr->incomplete = 0;
268     parsePtr->errorType = TCL_PARSE_SUCCESS;
269     if (nested != 0) {
270     terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
271     } else {
272     terminators = TYPE_COMMAND_END;
273     }
274    
275     /*
276     * Temporarily overwrite the character just after the end of the
277     * string with a 0 byte. This acts as a sentinel and reduces the
278     * number of places where we have to check for the end of the
279     * input string. The original value of the byte is restored at
280     * the end of the parse.
281     */
282    
283     savedChar = string[numBytes];
284     if (savedChar != 0) {
285     string[numBytes] = 0;
286     }
287    
288     /*
289     * Parse any leading space and comments before the first word of the
290     * command.
291     */
292    
293     src = string;
294     while (1) {
295     while ((CHAR_TYPE(*src) == TYPE_SPACE) || (*src == '\n')) {
296     src++;
297     }
298     if ((*src == '\\') && (src[1] == '\n')) {
299     /*
300     * Skip backslash-newline sequence: it should be treated
301     * just like white space.
302     */
303    
304     if ((src + 2) == parsePtr->end) {
305     parsePtr->incomplete = 1;
306     }
307     src += 2;
308     continue;
309     }
310     if (*src != '#') {
311     break;
312     }
313     if (parsePtr->commentStart == NULL) {
314     parsePtr->commentStart = src;
315     }
316     while (1) {
317     if (src == parsePtr->end) {
318     if (nested) {
319     parsePtr->incomplete = nested;
320     }
321     parsePtr->commentSize = src - parsePtr->commentStart;
322     break;
323     } else if (*src == '\\') {
324     if ((src[1] == '\n') && ((src + 2) == parsePtr->end)) {
325     parsePtr->incomplete = 1;
326     }
327     Tcl_UtfBackslash(src, &length, utfBytes);
328     src += length;
329     } else if (*src == '\n') {
330     src++;
331     parsePtr->commentSize = src - parsePtr->commentStart;
332     break;
333     } else {
334     src++;
335     }
336     }
337     }
338    
339     /*
340     * The following loop parses the words of the command, one word
341     * in each iteration through the loop.
342     */
343    
344     parsePtr->commandStart = src;
345     while (1) {
346     /*
347     * Create the token for the word.
348     */
349    
350     if (parsePtr->numTokens == parsePtr->tokensAvailable) {
351     TclExpandTokenArray(parsePtr);
352     }
353     wordIndex = parsePtr->numTokens;
354     tokenPtr = &parsePtr->tokenPtr[wordIndex];
355     tokenPtr->type = TCL_TOKEN_WORD;
356    
357     /*
358     * Skip white space before the word. Also skip a backslash-newline
359     * sequence: it should be treated just like white space.
360     */
361    
362     while (1) {
363     type = CHAR_TYPE(*src);
364     if (type == TYPE_SPACE) {
365     src++;
366     continue;
367     } else if ((*src == '\\') && (src[1] == '\n')) {
368     if ((src + 2) == parsePtr->end) {
369     parsePtr->incomplete = 1;
370     }
371     Tcl_UtfBackslash(src, &length, utfBytes);
372     src += length;
373     continue;
374     }
375     break;
376     }
377     if ((type & terminators) != 0) {
378     parsePtr->term = src;
379     src++;
380     break;
381     }
382     if (src == parsePtr->end) {
383     break;
384     }
385     tokenPtr->start = src;
386     parsePtr->numTokens++;
387     parsePtr->numWords++;
388    
389     /*
390     * At this point the word can have one of three forms: something
391     * enclosed in quotes, something enclosed in braces, or an
392     * unquoted word (anything else).
393     */
394    
395     if (*src == '"') {
396     if (Tcl_ParseQuotedString(interp, src, (parsePtr->end - src),
397     parsePtr, 1, &termPtr) != TCL_OK) {
398     goto error;
399     }
400     src = termPtr;
401     } else if (*src == '{') {
402     if (Tcl_ParseBraces(interp, src, (parsePtr->end - src),
403     parsePtr, 1, &termPtr) != TCL_OK) {
404     goto error;
405     }
406     src = termPtr;
407     } else {
408     /*
409     * This is an unquoted word. Call ParseTokens and let it do
410     * all of the work.
411     */
412    
413     if (ParseTokens(src, TYPE_SPACE|terminators,
414     parsePtr) != TCL_OK) {
415     goto error;
416     }
417     src = parsePtr->term;
418     }
419    
420     /*
421     * Finish filling in the token for the word and check for the
422     * special case of a word consisting of a single range of
423     * literal text.
424     */
425    
426     tokenPtr = &parsePtr->tokenPtr[wordIndex];
427     tokenPtr->size = src - tokenPtr->start;
428     tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
429     if ((tokenPtr->numComponents == 1)
430     && (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
431     tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
432     }
433    
434     /*
435     * Do two additional checks: (a) make sure we're really at the
436     * end of a word (there might have been garbage left after a
437     * quoted or braced word), and (b) check for the end of the
438     * command.
439     */
440    
441     type = CHAR_TYPE(*src);
442     if (type == TYPE_SPACE) {
443     src++;
444     continue;
445     } else {
446     /*
447     * Backslash-newline (and any following white space) must be
448     * treated as if it were a space character.
449     */
450    
451     if ((*src == '\\') && (src[1] == '\n')) {
452     if ((src + 2) == parsePtr->end) {
453     parsePtr->incomplete = 1;
454     }
455     Tcl_UtfBackslash(src, &length, utfBytes);
456     src += length;
457     continue;
458     }
459     }
460    
461     if ((type & terminators) != 0) {
462     parsePtr->term = src;
463     src++;
464     break;
465     }
466     if (src == parsePtr->end) {
467     break;
468     }
469     if (src[-1] == '"') {
470     if (interp != NULL) {
471     Tcl_SetResult(interp, "extra characters after close-quote",
472     TCL_STATIC);
473     }
474     parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
475     } else {
476     if (interp != NULL) {
477     Tcl_SetResult(interp, "extra characters after close-brace",
478     TCL_STATIC);
479     }
480     parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
481     }
482     parsePtr->term = src;
483     goto error;
484     }
485    
486    
487     parsePtr->commandSize = src - parsePtr->commandStart;
488     if (savedChar != 0) {
489     string[numBytes] = (char) savedChar;
490     }
491     return TCL_OK;
492    
493     error:
494     if (savedChar != 0) {
495     string[numBytes] = (char) savedChar;
496     }
497     Tcl_FreeParse(parsePtr);
498     if (parsePtr->commandStart == NULL) {
499     parsePtr->commandStart = string;
500     }
501     parsePtr->commandSize = parsePtr->term - parsePtr->commandStart;
502     return TCL_ERROR;
503     }
504    
505     /*
506     *----------------------------------------------------------------------
507     *
508     * ParseTokens --
509     *
510     * This procedure forms the heart of the Tcl parser. It parses one
511     * or more tokens from a string, up to a termination point
512     * specified by the caller. This procedure is used to parse
513     * unquoted command words (those not in quotes or braces), words in
514     * quotes, and array indices for variables.
515     *
516     * Results:
517     * Tokens are added to parsePtr and parsePtr->term is filled in
518     * with the address of the character that terminated the parse (the
519     * first one whose CHAR_TYPE matched mask or the character at
520     * parsePtr->end). The return value is TCL_OK if the parse
521     * completed successfully and TCL_ERROR otherwise. If a parse
522     * error occurs and parsePtr->interp isn't NULL, then an error
523     * message is left in the interpreter's result.
524     *
525     * Side effects:
526     * None.
527     *
528     *----------------------------------------------------------------------
529     */
530    
531     static int
532     ParseTokens(src, mask, parsePtr)
533     register char *src; /* First character to parse. */
534     int mask; /* Specifies when to stop parsing. The
535     * parse stops at the first unquoted
536     * character whose CHAR_TYPE contains
537     * any of the bits in mask. */
538     Tcl_Parse *parsePtr; /* Information about parse in progress.
539     * Updated with additional tokens and
540     * termination information. */
541     {
542     int type, originalTokens, varToken;
543     char utfBytes[TCL_UTF_MAX];
544     Tcl_Token *tokenPtr;
545     Tcl_Parse nested;
546    
547     /*
548     * Each iteration through the following loop adds one token of
549     * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or
550     * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens,
551     * additional tokens are added for the parsed variable name.
552     */
553    
554     originalTokens = parsePtr->numTokens;
555     while (1) {
556     if (parsePtr->numTokens == parsePtr->tokensAvailable) {
557     TclExpandTokenArray(parsePtr);
558     }
559     tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
560     tokenPtr->start = src;
561     tokenPtr->numComponents = 0;
562    
563     type = CHAR_TYPE(*src);
564     if (type & mask) {
565     break;
566     }
567    
568     if ((type & TYPE_SUBS) == 0) {
569     /*
570     * This is a simple range of characters. Scan to find the end
571     * of the range.
572     */
573    
574     while (1) {
575     src++;
576     if (CHAR_TYPE(*src) & (mask | TYPE_SUBS)) {
577     break;
578     }
579     }
580     tokenPtr->type = TCL_TOKEN_TEXT;
581     tokenPtr->size = src - tokenPtr->start;
582     parsePtr->numTokens++;
583     } else if (*src == '$') {
584     /*
585     * This is a variable reference. Call Tcl_ParseVarName to do
586     * all the dirty work of parsing the name.
587     */
588    
589     varToken = parsePtr->numTokens;
590     if (Tcl_ParseVarName(parsePtr->interp, src, parsePtr->end - src,
591     parsePtr, 1) != TCL_OK) {
592     return TCL_ERROR;
593     }
594     src += parsePtr->tokenPtr[varToken].size;
595     } else if (*src == '[') {
596     /*
597     * Command substitution. Call Tcl_ParseCommand recursively
598     * (and repeatedly) to parse the nested command(s), then
599     * throw away the parse information.
600     */
601    
602     src++;
603     while (1) {
604     if (Tcl_ParseCommand(parsePtr->interp, src,
605     parsePtr->end - src, 1, &nested) != TCL_OK) {
606     parsePtr->errorType = nested.errorType;
607     parsePtr->term = nested.term;
608     parsePtr->incomplete = nested.incomplete;
609     return TCL_ERROR;
610     }
611     src = nested.commandStart + nested.commandSize;
612     if (nested.tokenPtr != nested.staticTokens) {
613     ckfree((char *) nested.tokenPtr);
614     }
615     if ((*nested.term == ']') && !nested.incomplete) {
616     break;
617     }
618     if (src == parsePtr->end) {
619     if (parsePtr->interp != NULL) {
620     Tcl_SetResult(parsePtr->interp,
621     "missing close-bracket", TCL_STATIC);
622     }
623     parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
624     parsePtr->term = tokenPtr->start;
625     parsePtr->incomplete = 1;
626     return TCL_ERROR;
627     }
628     }
629     tokenPtr->type = TCL_TOKEN_COMMAND;
630     tokenPtr->size = src - tokenPtr->start;
631     parsePtr->numTokens++;
632     } else if (*src == '\\') {
633     /*
634     * Backslash substitution.
635     */
636    
637     if (src[1] == '\n') {
638     if ((src + 2) == parsePtr->end) {
639     parsePtr->incomplete = 1;
640     }
641    
642     /*
643     * Note: backslash-newline is special in that it is
644     * treated the same as a space character would be. This
645     * means that it could terminate the token.
646     */
647    
648     if (mask & TYPE_SPACE) {
649     break;
650     }
651     }
652     tokenPtr->type = TCL_TOKEN_BS;
653     Tcl_UtfBackslash(src, &tokenPtr->size, utfBytes);
654     parsePtr->numTokens++;
655     src += tokenPtr->size;
656     } else if (*src == 0) {
657     /*
658     * We encountered a null character. If it is the null
659     * character at the end of the string, then return.
660     * Otherwise generate a text token for the single
661     * character.
662     */
663    
664     if (src == parsePtr->end) {
665     break;
666     }
667     tokenPtr->type = TCL_TOKEN_TEXT;
668     tokenPtr->size = 1;
669     parsePtr->numTokens++;
670     src++;
671     } else {
672     panic("ParseTokens encountered unknown character");
673     }
674     }
675     if (parsePtr->numTokens == originalTokens) {
676     /*
677     * There was nothing in this range of text. Add an empty token
678     * for the empty range, so that there is always at least one
679     * token added.
680     */
681    
682     tokenPtr->type = TCL_TOKEN_TEXT;
683     tokenPtr->size = 0;
684     parsePtr->numTokens++;
685     }
686     parsePtr->term = src;
687     return TCL_OK;
688     }
689    
690     /*
691     *----------------------------------------------------------------------
692     *
693     * Tcl_FreeParse --
694     *
695     * This procedure is invoked to free any dynamic storage that may
696     * have been allocated by a previous call to Tcl_ParseCommand.
697     *
698     * Results:
699     * None.
700     *
701     * Side effects:
702     * If there is any dynamically allocated memory in *parsePtr,
703     * it is freed.
704     *
705     *----------------------------------------------------------------------
706     */
707    
708     void
709     Tcl_FreeParse(parsePtr)
710     Tcl_Parse *parsePtr; /* Structure that was filled in by a
711     * previous call to Tcl_ParseCommand. */
712     {
713     if (parsePtr->tokenPtr != parsePtr->staticTokens) {
714     ckfree((char *) parsePtr->tokenPtr);
715     parsePtr->tokenPtr = parsePtr->staticTokens;
716     }
717     }
718    
719     /*
720     *----------------------------------------------------------------------
721     *
722     * TclExpandTokenArray --
723     *
724     * This procedure is invoked when the current space for tokens in
725     * a Tcl_Parse structure fills up; it allocates memory to grow the
726     * token array
727     *
728     * Results:
729     * None.
730     *
731     * Side effects:
732     * Memory is allocated for a new larger token array; the memory
733     * for the old array is freed, if it had been dynamically allocated.
734     *
735     *----------------------------------------------------------------------
736     */
737    
738     void
739     TclExpandTokenArray(parsePtr)
740     Tcl_Parse *parsePtr; /* Parse structure whose token space
741     * has overflowed. */
742     {
743     int newCount;
744     Tcl_Token *newPtr;
745    
746     newCount = parsePtr->tokensAvailable*2;
747     newPtr = (Tcl_Token *) ckalloc((unsigned) (newCount * sizeof(Tcl_Token)));
748     memcpy((VOID *) newPtr, (VOID *) parsePtr->tokenPtr,
749     (size_t) (parsePtr->tokensAvailable * sizeof(Tcl_Token)));
750     if (parsePtr->tokenPtr != parsePtr->staticTokens) {
751     ckfree((char *) parsePtr->tokenPtr);
752     }
753     parsePtr->tokenPtr = newPtr;
754     parsePtr->tokensAvailable = newCount;
755     }
756    
757     /*
758     *----------------------------------------------------------------------
759     *
760     * EvalObjv --
761     *
762     * This procedure evaluates a Tcl command that has already been
763     * parsed into words, with one Tcl_Obj holding each word.
764     *
765     * Results:
766     * The return value is a standard Tcl completion code such as
767     * TCL_OK or TCL_ERROR. A result or error message is left in
768     * interp's result. If an error occurs, this procedure does
769     * NOT add any information to the errorInfo variable.
770     *
771     * Side effects:
772     * Depends on the command.
773     *
774     *----------------------------------------------------------------------
775     */
776    
777     static int
778     EvalObjv(interp, objc, objv, command, length, flags)
779     Tcl_Interp *interp; /* Interpreter in which to evaluate the
780     * command. Also used for error
781     * reporting. */
782     int objc; /* Number of words in command. */
783     Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
784     * the words that make up the command. */
785     char *command; /* Points to the beginning of the string
786     * representation of the command; this
787     * is used for traces. If the string
788     * representation of the command is
789     * unknown, an empty string should be
790     * supplied. */
791     int length; /* Number of bytes in command; if -1, all
792     * characters up to the first null byte are
793     * used. */
794     int flags; /* Collection of OR-ed bits that control
795     * the evaluation of the script. Only
796     * TCL_EVAL_GLOBAL is currently
797     * supported. */
798    
799     {
800     Command *cmdPtr;
801     Interp *iPtr = (Interp *) interp;
802     Tcl_Obj **newObjv;
803     int i, code;
804     Trace *tracePtr, *nextPtr;
805     char **argv, *commandCopy;
806     CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
807     * in case TCL_EVAL_GLOBAL was set. */
808    
809     Tcl_ResetResult(interp);
810     if (objc == 0) {
811     return TCL_OK;
812     }
813    
814     /*
815     * If the interpreter was deleted, return an error.
816     */
817    
818     if (iPtr->flags & DELETED) {
819     Tcl_AppendToObj(Tcl_GetObjResult(interp),
820     "attempt to call eval in deleted interpreter", -1);
821     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
822     "attempt to call eval in deleted interpreter",
823     (char *) NULL);
824     return TCL_ERROR;
825     }
826    
827     /*
828     * Check depth of nested calls to Tcl_Eval: if this gets too large,
829     * it's probably because of an infinite loop somewhere.
830     */
831    
832     if (iPtr->numLevels >= iPtr->maxNestingDepth) {
833     iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
834     return TCL_ERROR;
835     }
836     iPtr->numLevels++;
837    
838     /*
839     * On the Mac, we will never reach the default recursion limit before
840     * blowing the stack. So we need to do a check here.
841     */
842    
843     if (TclpCheckStackSpace() == 0) {
844     /*NOTREACHED*/
845     iPtr->numLevels--;
846     iPtr->result = "too many nested calls to Tcl_Eval (infinite loop?)";
847     return TCL_ERROR;
848     }
849    
850     /*
851     * Find the procedure to execute this command. If there isn't one,
852     * then see if there is a command "unknown". If so, create a new
853     * word array with "unknown" as the first word and the original
854     * command words as arguments. Then call ourselves recursively
855     * to execute it.
856     */
857    
858     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
859     if (cmdPtr == NULL) {
860     newObjv = (Tcl_Obj **) ckalloc((unsigned)
861     ((objc + 1) * sizeof (Tcl_Obj *)));
862     for (i = objc-1; i >= 0; i--) {
863     newObjv[i+1] = objv[i];
864     }
865     newObjv[0] = Tcl_NewStringObj("unknown", -1);
866     Tcl_IncrRefCount(newObjv[0]);
867     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, newObjv[0]);
868     if (cmdPtr == NULL) {
869     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
870     "invalid command name \"", Tcl_GetString(objv[0]), "\"",
871     (char *) NULL);
872     code = TCL_ERROR;
873     } else {
874     code = EvalObjv(interp, objc+1, newObjv, command, length, 0);
875     }
876     Tcl_DecrRefCount(newObjv[0]);
877     ckfree((char *) newObjv);
878     goto done;
879     }
880    
881     /*
882     * Call trace procedures if needed.
883     */
884    
885     argv = NULL;
886     commandCopy = command;
887    
888     for (tracePtr = iPtr->tracePtr; tracePtr != NULL; tracePtr = nextPtr) {
889     nextPtr = tracePtr->nextPtr;
890     if (iPtr->numLevels > tracePtr->level) {
891     continue;
892     }
893    
894     /*
895     * This is a bit messy because we have to emulate the old trace
896     * interface, which uses strings for everything.
897     */
898    
899     if (argv == NULL) {
900     argv = (char **) ckalloc((unsigned) (objc + 1) * sizeof(char *));
901     for (i = 0; i < objc; i++) {
902     argv[i] = Tcl_GetString(objv[i]);
903     }
904     argv[objc] = 0;
905    
906     if (length < 0) {
907     length = strlen(command);
908     } else if ((size_t)length < strlen(command)) {
909     commandCopy = (char *) ckalloc((unsigned) (length + 1));
910     strncpy(commandCopy, command, (size_t) length);
911     commandCopy[length] = 0;
912     }
913     }
914     (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
915     commandCopy, cmdPtr->proc, cmdPtr->clientData,
916     objc, argv);
917     }
918     if (argv != NULL) {
919     ckfree((char *) argv);
920     }
921     if (commandCopy != command) {
922     ckfree((char *) commandCopy);
923     }
924    
925     /*
926     * Finally, invoke the command's Tcl_ObjCmdProc.
927     */
928    
929     iPtr->cmdCount++;
930     savedVarFramePtr = iPtr->varFramePtr;
931     if (flags & TCL_EVAL_GLOBAL) {
932     iPtr->varFramePtr = NULL;
933     }
934     code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv);
935     iPtr->varFramePtr = savedVarFramePtr;
936     if (Tcl_AsyncReady()) {
937     code = Tcl_AsyncInvoke(interp, code);
938     }
939    
940     /*
941     * If the interpreter has a non-empty string result, the result
942     * object is either empty or stale because some procedure set
943     * interp->result directly. If so, move the string result to the
944     * result object, then reset the string result.
945     */
946    
947     if (*(iPtr->result) != 0) {
948     (void) Tcl_GetObjResult(interp);
949     }
950    
951     done:
952     iPtr->numLevels--;
953     return code;
954     }
955    
956     /*
957     *----------------------------------------------------------------------
958     *
959     * Tcl_EvalObjv --
960     *
961     * This procedure evaluates a Tcl command that has already been
962     * parsed into words, with one Tcl_Obj holding each word.
963     *
964     * Results:
965     * The return value is a standard Tcl completion code such as
966     * TCL_OK or TCL_ERROR. A result or error message is left in
967     * interp's result.
968     *
969     * Side effects:
970     * Depends on the command.
971     *
972     *----------------------------------------------------------------------
973     */
974    
975     int
976     Tcl_EvalObjv(interp, objc, objv, flags)
977     Tcl_Interp *interp; /* Interpreter in which to evaluate the
978     * command. Also used for error
979     * reporting. */
980     int objc; /* Number of words in command. */
981     Tcl_Obj *CONST objv[]; /* An array of pointers to objects that are
982     * the words that make up the command. */
983     int flags; /* Collection of OR-ed bits that control
984     * the evaluation of the script. Only
985     * TCL_EVAL_GLOBAL is currently
986     * supported. */
987     {
988     Interp *iPtr = (Interp *)interp;
989     Trace *tracePtr;
990     Tcl_DString cmdBuf;
991     char *cmdString = "";
992     int cmdLen = 0;
993     int code = TCL_OK;
994    
995     for (tracePtr = iPtr->tracePtr; tracePtr; tracePtr = tracePtr->nextPtr) {
996     /*
997     * EvalObjv will increment numLevels so use "<" rather than "<="
998     */
999     if (iPtr->numLevels < tracePtr->level) {
1000     int i;
1001     /*
1002     * The command will be needed for an execution trace or stack trace
1003     * generate a command string.
1004     */
1005     cmdtraced:
1006     Tcl_DStringInit(&cmdBuf);
1007     for (i = 0; i < objc; i++) {
1008     Tcl_DStringAppendElement(&cmdBuf, Tcl_GetString(objv[i]));
1009     }
1010     cmdString = Tcl_DStringValue(&cmdBuf);
1011     cmdLen = Tcl_DStringLength(&cmdBuf);
1012     break;
1013     }
1014     }
1015    
1016     /*
1017     * Execute the command if we have not done so already
1018     */
1019     switch (code) {
1020     case TCL_OK:
1021     code = EvalObjv(interp, objc, objv, cmdString, cmdLen, flags);
1022     if (code == TCL_ERROR && cmdLen == 0)
1023     goto cmdtraced;
1024     break;
1025     case TCL_ERROR:
1026     Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen);
1027     break;
1028     default:
1029     /*NOTREACHED*/
1030     break;
1031     }
1032    
1033     if (cmdLen != 0) {
1034     Tcl_DStringFree(&cmdBuf);
1035     }
1036     return code;
1037     }
1038    
1039     /*
1040     *----------------------------------------------------------------------
1041     *
1042     * Tcl_LogCommandInfo --
1043     *
1044     * This procedure is invoked after an error occurs in an interpreter.
1045     * It adds information to the "errorInfo" variable to describe the
1046     * command that was being executed when the error occurred.
1047     *
1048     * Results:
1049     * None.
1050     *
1051     * Side effects:
1052     * Information about the command is added to errorInfo and the
1053     * line number stored internally in the interpreter is set. If this
1054     * is the first call to this procedure or Tcl_AddObjErrorInfo since
1055     * an error occurred, then old information in errorInfo is
1056     * deleted.
1057     *
1058     *----------------------------------------------------------------------
1059     */
1060    
1061     void
1062     Tcl_LogCommandInfo(interp, script, command, length)
1063     Tcl_Interp *interp; /* Interpreter in which to log information. */
1064     char *script; /* First character in script containing
1065     * command (must be <= command). */
1066     char *command; /* First character in command that
1067     * generated the error. */
1068     int length; /* Number of bytes in command (-1 means
1069     * use all bytes up to first null byte). */
1070     {
1071     char buffer[200];
1072     register char *p;
1073     char *ellipsis = "";
1074     Interp *iPtr = (Interp *) interp;
1075    
1076     if (iPtr->flags & ERR_ALREADY_LOGGED) {
1077     /*
1078     * Someone else has already logged error information for this
1079     * command; we shouldn't add anything more.
1080     */
1081    
1082     return;
1083     }
1084    
1085     /*
1086     * Compute the line number where the error occurred.
1087     */
1088    
1089     iPtr->errorLine = 1;
1090     for (p = script; p != command; p++) {
1091     if (*p == '\n') {
1092     iPtr->errorLine++;
1093     }
1094     }
1095    
1096     /*
1097     * Create an error message to add to errorInfo, including up to a
1098     * maximum number of characters of the command.
1099     */
1100    
1101     if (length < 0) {
1102     length = strlen(command);
1103     }
1104     if (length > 150) {
1105     length = 150;
1106     ellipsis = "...";
1107     }
1108     if (!(iPtr->flags & ERR_IN_PROGRESS)) {
1109     sprintf(buffer, "\n while executing\n\"%.*s%s\"",
1110     length, command, ellipsis);
1111     } else {
1112     sprintf(buffer, "\n invoked from within\n\"%.*s%s\"",
1113     length, command, ellipsis);
1114     }
1115     Tcl_AddObjErrorInfo(interp, buffer, -1);
1116     iPtr->flags &= ~ERR_ALREADY_LOGGED;
1117     }
1118    
1119     /*
1120     *----------------------------------------------------------------------
1121     *
1122     * Tcl_EvalTokens --
1123     *
1124     * Given an array of tokens parsed from a Tcl command (e.g., the
1125     * tokens that make up a word or the index for an array variable)
1126     * this procedure evaluates the tokens and concatenates their
1127     * values to form a single result value.
1128     *
1129     * Results:
1130     * The return value is a pointer to a newly allocated Tcl_Obj
1131     * containing the value of the array of tokens. The reference
1132     * count of the returned object has been incremented. If an error
1133     * occurs in evaluating the tokens then a NULL value is returned
1134     * and an error message is left in interp's result.
1135     *
1136     * Side effects:
1137     * A new object is allocated to hold the result.
1138     *
1139     *----------------------------------------------------------------------
1140     */
1141    
1142     Tcl_Obj *
1143     Tcl_EvalTokens(interp, tokenPtr, count)
1144     Tcl_Interp *interp; /* Interpreter in which to lookup
1145     * variables, execute nested commands,
1146     * and report errors. */
1147     Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1148     * to evaluate and concatenate. */
1149     int count; /* Number of tokens to consider at tokenPtr.
1150     * Must be at least 1. */
1151     {
1152     Tcl_Obj *resultPtr, *indexPtr, *valuePtr, *newPtr;
1153     char buffer[TCL_UTF_MAX];
1154     #ifdef TCL_MEM_DEBUG
1155     # define MAX_VAR_CHARS 5
1156     #else
1157     # define MAX_VAR_CHARS 30
1158     #endif
1159     char nameBuffer[MAX_VAR_CHARS+1];
1160     char *varName, *index;
1161     char *p = NULL; /* Initialized to avoid compiler warning. */
1162     int length, code;
1163    
1164     /*
1165     * The only tricky thing about this procedure is that it attempts to
1166     * avoid object creation and string copying whenever possible. For
1167     * example, if the value is just a nested command, then use the
1168     * command's result object directly.
1169     */
1170    
1171     resultPtr = NULL;
1172     for ( ; count > 0; count--, tokenPtr++) {
1173     valuePtr = NULL;
1174    
1175     /*
1176     * The switch statement below computes the next value to be
1177     * concat to the result, as either a range of text or an
1178     * object.
1179     */
1180    
1181     switch (tokenPtr->type) {
1182     case TCL_TOKEN_TEXT:
1183     p = tokenPtr->start;
1184     length = tokenPtr->size;
1185     break;
1186    
1187     case TCL_TOKEN_BS:
1188     length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
1189     buffer);
1190     p = buffer;
1191     break;
1192    
1193     case TCL_TOKEN_COMMAND:
1194     code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
1195     0);
1196     if (code != TCL_OK) {
1197     goto error;
1198     }
1199     valuePtr = Tcl_GetObjResult(interp);
1200     break;
1201    
1202     case TCL_TOKEN_VARIABLE:
1203     if (tokenPtr->numComponents == 1) {
1204     indexPtr = NULL;
1205     } else {
1206     indexPtr = Tcl_EvalTokens(interp, tokenPtr+2,
1207     tokenPtr->numComponents - 1);
1208     if (indexPtr == NULL) {
1209     goto error;
1210     }
1211     }
1212    
1213     /*
1214     * We have to make a copy of the variable name in order
1215     * to have a null-terminated string. We can't make a
1216     * temporary modification to the script to null-terminate
1217     * the name, because a trace callback might potentially
1218     * reuse the script and be affected by the null character.
1219     */
1220    
1221     if (tokenPtr[1].size <= MAX_VAR_CHARS) {
1222     varName = nameBuffer;
1223     } else {
1224     varName = ckalloc((unsigned) (tokenPtr[1].size + 1));
1225     }
1226     strncpy(varName, tokenPtr[1].start, (size_t) tokenPtr[1].size);
1227     varName[tokenPtr[1].size] = 0;
1228     if (indexPtr != NULL) {
1229     index = TclGetString(indexPtr);
1230     } else {
1231     index = NULL;
1232     }
1233     valuePtr = Tcl_GetVar2Ex(interp, varName, index,
1234     TCL_LEAVE_ERR_MSG);
1235     if (varName != nameBuffer) {
1236     ckfree(varName);
1237     }
1238     if (indexPtr != NULL) {
1239     Tcl_DecrRefCount(indexPtr);
1240     }
1241     if (valuePtr == NULL) {
1242     goto error;
1243     }
1244     count -= tokenPtr->numComponents;
1245     tokenPtr += tokenPtr->numComponents;
1246     break;
1247    
1248     default:
1249     panic("unexpected token type in Tcl_EvalTokens");
1250     }
1251    
1252     /*
1253     * If valuePtr isn't NULL, the next piece of text comes from that
1254     * object; otherwise, take length bytes starting at p.
1255     */
1256    
1257     if (resultPtr == NULL) {
1258     if (valuePtr != NULL) {
1259     resultPtr = valuePtr;
1260     } else {
1261     resultPtr = Tcl_NewStringObj(p, length);
1262     }
1263     Tcl_IncrRefCount(resultPtr);
1264     } else {
1265     if (Tcl_IsShared(resultPtr)) {
1266     newPtr = Tcl_DuplicateObj(resultPtr);
1267     Tcl_DecrRefCount(resultPtr);
1268     resultPtr = newPtr;
1269     Tcl_IncrRefCount(resultPtr);
1270     }
1271     if (valuePtr != NULL) {
1272     p = Tcl_GetStringFromObj(valuePtr, &length);
1273     }
1274     Tcl_AppendToObj(resultPtr, p, length);
1275     }
1276     }
1277     return resultPtr;
1278    
1279     error:
1280     if (resultPtr != NULL) {
1281     Tcl_DecrRefCount(resultPtr);
1282     }
1283     return NULL;
1284     }
1285    
1286     /*
1287     *----------------------------------------------------------------------
1288     *
1289     * Tcl_EvalEx --
1290     *
1291     * This procedure evaluates a Tcl script without using the compiler
1292     * or byte-code interpreter. It just parses the script, creates
1293     * values for each word of each command, then calls EvalObjv
1294     * to execute each command.
1295     *
1296     * Results:
1297     * The return value is a standard Tcl completion code such as
1298     * TCL_OK or TCL_ERROR. A result or error message is left in
1299     * interp's result.
1300     *
1301     * Side effects:
1302     * Depends on the script.
1303     *
1304     *----------------------------------------------------------------------
1305     */
1306    
1307     int
1308     Tcl_EvalEx(interp, script, numBytes, flags)
1309     Tcl_Interp *interp; /* Interpreter in which to evaluate the
1310     * script. Also used for error reporting. */
1311     char *script; /* First character of script to evaluate. */
1312     int numBytes; /* Number of bytes in script. If < 0, the
1313     * script consists of all bytes up to the
1314     * first null character. */
1315     int flags; /* Collection of OR-ed bits that control
1316     * the evaluation of the script. Only
1317     * TCL_EVAL_GLOBAL is currently
1318     * supported. */
1319     {
1320     Interp *iPtr = (Interp *) interp;
1321     char *p, *next;
1322     Tcl_Parse parse;
1323     #define NUM_STATIC_OBJS 20
1324     Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv;
1325     Tcl_Token *tokenPtr;
1326     int i, code, commandLength, bytesLeft, nested;
1327     CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
1328     * in case TCL_EVAL_GLOBAL was set. */
1329    
1330     /*
1331     * The variables below keep track of how much state has been
1332     * allocated while evaluating the script, so that it can be freed
1333     * properly if an error occurs.
1334     */
1335    
1336     int gotParse = 0, objectsUsed = 0;
1337    
1338     if (numBytes < 0) {
1339     numBytes = strlen(script);
1340     }
1341     Tcl_ResetResult(interp);
1342    
1343     savedVarFramePtr = iPtr->varFramePtr;
1344     if (flags & TCL_EVAL_GLOBAL) {
1345     iPtr->varFramePtr = NULL;
1346     }
1347    
1348     /*
1349     * Each iteration through the following loop parses the next
1350     * command from the script and then executes it.
1351     */
1352    
1353     objv = staticObjArray;
1354     p = script;
1355     bytesLeft = numBytes;
1356     if (iPtr->evalFlags & TCL_BRACKET_TERM) {
1357     nested = 1;
1358     } else {
1359     nested = 0;
1360     }
1361     iPtr->evalFlags = 0;
1362     do {
1363     if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse)
1364     != TCL_OK) {
1365     code = TCL_ERROR;
1366     goto error;
1367     }
1368     gotParse = 1;
1369     if (parse.numWords > 0) {
1370     /*
1371     * Generate an array of objects for the words of the command.
1372     */
1373    
1374     if (parse.numWords <= NUM_STATIC_OBJS) {
1375     objv = staticObjArray;
1376     } else {
1377     objv = (Tcl_Obj **) ckalloc((unsigned)
1378     (parse.numWords * sizeof (Tcl_Obj *)));
1379     }
1380     for (objectsUsed = 0, tokenPtr = parse.tokenPtr;
1381     objectsUsed < parse.numWords;
1382     objectsUsed++, tokenPtr += (tokenPtr->numComponents + 1)) {
1383     objv[objectsUsed] = Tcl_EvalTokens(interp, tokenPtr+1,
1384     tokenPtr->numComponents);
1385     if (objv[objectsUsed] == NULL) {
1386     code = TCL_ERROR;
1387     goto error;
1388     }
1389     }
1390    
1391     /*
1392     * Execute the command and free the objects for its words.
1393     */
1394    
1395     code = EvalObjv(interp, objectsUsed, objv, p, bytesLeft, 0);
1396     if (code != TCL_OK) {
1397     goto error;
1398     }
1399     for (i = 0; i < objectsUsed; i++) {
1400     Tcl_DecrRefCount(objv[i]);
1401     }
1402     objectsUsed = 0;
1403     if (objv != staticObjArray) {
1404     ckfree((char *) objv);
1405     objv = staticObjArray;
1406     }
1407     }
1408    
1409     /*
1410     * Advance to the next command in the script.
1411     */
1412    
1413     next = parse.commandStart + parse.commandSize;
1414     bytesLeft -= next - p;
1415     p = next;
1416     Tcl_FreeParse(&parse);
1417     gotParse = 0;
1418     if ((nested != 0) && (p > script) && (p[-1] == ']')) {
1419     /*
1420     * We get here in the special case where the TCL_BRACKET_TERM
1421     * flag was set in the interpreter and we reached a close
1422     * bracket in the script. Return immediately.
1423     */
1424    
1425     iPtr->termOffset = (p - 1) - script;
1426     iPtr->varFramePtr = savedVarFramePtr;
1427     return TCL_OK;
1428     }
1429     } while (bytesLeft > 0);
1430     iPtr->termOffset = p - script;
1431     iPtr->varFramePtr = savedVarFramePtr;
1432     return TCL_OK;
1433    
1434     error:
1435     /*
1436     * Generate various pieces of error information, such as the line
1437     * number where the error occurred and information to add to the
1438     * errorInfo variable. Then free resources that had been allocated
1439     * to the command.
1440     */
1441    
1442     if ((code == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1443     commandLength = parse.commandSize;
1444     if ((parse.commandStart + commandLength) != (script + numBytes)) {
1445     /*
1446     * The command where the error occurred didn't end at the end
1447     * of the script (i.e. it ended at a terminator character such
1448     * as ";". Reduce the length by one so that the error message
1449     * doesn't include the terminator character.
1450     */
1451    
1452     commandLength -= 1;
1453     }
1454     Tcl_LogCommandInfo(interp, script, parse.commandStart, commandLength);
1455     }
1456    
1457     for (i = 0; i < objectsUsed; i++) {
1458     Tcl_DecrRefCount(objv[i]);
1459     }
1460     if (gotParse) {
1461     p = parse.commandStart + parse.commandSize;
1462     Tcl_FreeParse(&parse);
1463     if ((nested != 0) && (p > script) && (p[-1] == ']')) {
1464     /*
1465     * We get here in the special case where the TCL_BRACKET_TERM
1466     * flag was set in the interpreter and we reached a close
1467     * bracket in the script. Return immediately.
1468     */
1469    
1470     iPtr->termOffset = (p - 1) - script;
1471     } else {
1472     iPtr->termOffset = p - script;
1473     }
1474     }
1475     if (objv != staticObjArray) {
1476     ckfree((char *) objv);
1477     }
1478     iPtr->varFramePtr = savedVarFramePtr;
1479     return code;
1480     }
1481    
1482     /*
1483     *----------------------------------------------------------------------
1484     *
1485     * Tcl_Eval --
1486     *
1487     * Execute a Tcl command in a string. This procedure executes the
1488     * script directly, rather than compiling it to bytecodes. Before
1489     * the arrival of the bytecode compiler in Tcl 8.0 Tcl_Eval was
1490     * the main procedure used for executing Tcl commands, but nowadays
1491     * it isn't used much.
1492     *
1493     * Results:
1494     * The return value is one of the return codes defined in tcl.h
1495     * (such as TCL_OK), and interp's result contains a value
1496     * to supplement the return code. The value of the result
1497     * will persist only until the next call to Tcl_Eval or Tcl_EvalObj:
1498     * you must copy it or lose it!
1499     *
1500     * Side effects:
1501     * Can be almost arbitrary, depending on the commands in the script.
1502     *
1503     *----------------------------------------------------------------------
1504     */
1505    
1506     int
1507     Tcl_Eval(interp, string)
1508     Tcl_Interp *interp; /* Token for command interpreter (returned
1509     * by previous call to Tcl_CreateInterp). */
1510     char *string; /* Pointer to TCL command to execute. */
1511     {
1512     int code;
1513    
1514     code = Tcl_EvalEx(interp, string, -1, 0);
1515    
1516     /*
1517     * For backwards compatibility with old C code that predates the
1518     * object system in Tcl 8.0, we have to mirror the object result
1519     * back into the string result (some callers may expect it there).
1520     */
1521    
1522     Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
1523     TCL_VOLATILE);
1524     return code;
1525     }
1526    
1527     /*
1528     *----------------------------------------------------------------------
1529     *
1530     * Tcl_EvalObj, Tcl_GlobalEvalObj --
1531     *
1532     * These functions are deprecated but we keep them around for backwards
1533     * compatibility reasons.
1534     *
1535     * Results:
1536     * See the functions they call.
1537     *
1538     * Side effects:
1539     * See the functions they call.
1540     *
1541     *----------------------------------------------------------------------
1542     */
1543    
1544     #undef Tcl_EvalObj
1545     int
1546     Tcl_EvalObj(interp, objPtr)
1547     Tcl_Interp * interp;
1548     Tcl_Obj * objPtr;
1549     {
1550     return Tcl_EvalObjEx(interp, objPtr, 0);
1551     }
1552    
1553     #undef Tcl_GlobalEvalObj
1554     int
1555     Tcl_GlobalEvalObj(interp, objPtr)
1556     Tcl_Interp * interp;
1557     Tcl_Obj * objPtr;
1558     {
1559     return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
1560     }
1561    
1562     /*
1563     *----------------------------------------------------------------------
1564     *
1565     * Tcl_ParseVarName --
1566     *
1567     * Given a string starting with a $ sign, parse off a variable
1568     * name and return information about the parse.
1569     *
1570     * Results:
1571     * The return value is TCL_OK if the command was parsed
1572     * successfully and TCL_ERROR otherwise. If an error occurs and
1573     * interp isn't NULL then an error message is left in its result.
1574     * On a successful return, tokenPtr and numTokens fields of
1575     * parsePtr are filled in with information about the variable name
1576     * that was parsed. The "size" field of the first new token gives
1577     * the total number of bytes in the variable name. Other fields in
1578     * parsePtr are undefined.
1579     *
1580     * Side effects:
1581     * If there is insufficient space in parsePtr to hold all the
1582     * information about the command, then additional space is
1583     * malloc-ed. If the procedure returns TCL_OK then the caller must
1584     * eventually invoke Tcl_FreeParse to release any additional space
1585     * that was allocated.
1586     *
1587     *----------------------------------------------------------------------
1588     */
1589    
1590     int
1591     Tcl_ParseVarName(interp, string, numBytes, parsePtr, append)
1592     Tcl_Interp *interp; /* Interpreter to use for error reporting;
1593     * if NULL, then no error message is
1594     * provided. */
1595     char *string; /* String containing variable name. First
1596     * character must be "$". */
1597     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     Tcl_Parse *parsePtr; /* Structure to fill in with information
1601     * about the variable name. */
1602     int append; /* Non-zero means append tokens to existing
1603     * information in parsePtr; zero means ignore
1604     * existing tokens in parsePtr and reinitialize
1605     * it. */
1606     {
1607     Tcl_Token *tokenPtr;
1608     char *end, *src;
1609     unsigned char c;
1610     int varIndex, offset;
1611     Tcl_UniChar ch;
1612     unsigned array;
1613    
1614     if (numBytes >= 0) {
1615     end = string + numBytes;
1616     } else {
1617     end = string + strlen(string);
1618     }
1619    
1620     if (!append) {
1621     parsePtr->numWords = 0;
1622     parsePtr->tokenPtr = parsePtr->staticTokens;
1623     parsePtr->numTokens = 0;
1624     parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
1625     parsePtr->string = string;
1626     parsePtr->end = end;
1627     parsePtr->interp = interp;
1628     parsePtr->errorType = TCL_PARSE_SUCCESS;
1629     parsePtr->incomplete = 0;
1630     }
1631    
1632     /*
1633     * Generate one token for the variable, an additional token for the
1634     * name, plus any number of additional tokens for the index, if
1635     * there is one.
1636     */
1637    
1638     src = string;
1639     if ((parsePtr->numTokens + 2) > parsePtr->tokensAvailable) {
1640     TclExpandTokenArray(parsePtr);
1641     }
1642     tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1643     tokenPtr->type = TCL_TOKEN_VARIABLE;
1644     tokenPtr->start = src;
1645     varIndex = parsePtr->numTokens;
1646     parsePtr->numTokens++;
1647     tokenPtr++;
1648     src++;
1649     if (src >= end) {
1650     goto justADollarSign;
1651     }
1652     tokenPtr->type = TCL_TOKEN_TEXT;
1653     tokenPtr->start = src;
1654     tokenPtr->numComponents = 0;
1655    
1656     /*
1657     * The name of the variable can have three forms:
1658     * 1. The $ sign is followed by an open curly brace. Then
1659     * the variable name is everything up to the next close
1660     * curly brace, and the variable is a scalar variable.
1661     * 2. The $ sign is not followed by an open curly brace. Then
1662     * the variable name is everything up to the next
1663     * character that isn't a letter, digit, or underscore.
1664     * :: sequences are also considered part of the variable
1665     * name, in order to support namespaces. If the following
1666     * character is an open parenthesis, then the information
1667     * between parentheses is the array element name.
1668     * 3. The $ sign is followed by something that isn't a letter,
1669     * digit, or underscore: in this case, there is no variable
1670     * name and the token is just "$".
1671     */
1672    
1673     if (*src == '{') {
1674     src++;
1675     tokenPtr->type = TCL_TOKEN_TEXT;
1676     tokenPtr->start = src;
1677     tokenPtr->numComponents = 0;
1678     while (1) {
1679     if (src == end) {
1680     if (interp != NULL) {
1681     Tcl_SetResult(interp,
1682     "missing close-brace for variable name",
1683     TCL_STATIC);
1684     }
1685     parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
1686     parsePtr->term = tokenPtr->start-1;
1687     parsePtr->incomplete = 1;
1688     goto error;
1689     }
1690     if (*src == '}') {
1691     break;
1692     }
1693     src++;
1694     }
1695     tokenPtr->size = src - tokenPtr->start;
1696     tokenPtr[-1].size = src - tokenPtr[-1].start;
1697     parsePtr->numTokens++;
1698     src++;
1699     } else {
1700     tokenPtr->type = TCL_TOKEN_TEXT;
1701     tokenPtr->start = src;
1702     tokenPtr->numComponents = 0;
1703     while (src != end) {
1704     offset = Tcl_UtfToUniChar(src, &ch);
1705     c = UCHAR(ch);
1706     if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */
1707     src += offset;
1708     continue;
1709     }
1710     if ((c == ':') && (((src+1) != end) && (src[1] == ':'))) {
1711     src += 2;
1712     while ((src != end) && (*src == ':')) {
1713     src += 1;
1714     }
1715     continue;
1716     }
1717     break;
1718     }
1719    
1720     /*
1721     * Support for empty array names here.
1722     */
1723     array = ((src != end) && (*src == '('));
1724     tokenPtr->size = src - tokenPtr->start;
1725     if (tokenPtr->size == 0 && !array) {
1726     goto justADollarSign;
1727     }
1728     parsePtr->numTokens++;
1729     if (array) {
1730     /*
1731     * This is a reference to an array element. Call
1732     * ParseTokens recursively to parse the element name,
1733     * since it could contain any number of substitutions.
1734     */
1735    
1736     if (ParseTokens(src+1, TYPE_CLOSE_PAREN, parsePtr)
1737     != TCL_OK) {
1738     goto error;
1739     }
1740     if ((parsePtr->term == end) || (*parsePtr->term != ')')) {
1741     if (parsePtr->interp != NULL) {
1742     Tcl_SetResult(parsePtr->interp, "missing )",
1743     TCL_STATIC);
1744     }
1745     parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
1746     parsePtr->term = src;
1747     parsePtr->incomplete = 1;
1748     goto error;
1749     }
1750     src = parsePtr->term + 1;
1751     }
1752     }
1753     tokenPtr = &parsePtr->tokenPtr[varIndex];
1754     tokenPtr->size = src - tokenPtr->start;
1755     tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
1756     return TCL_OK;
1757    
1758     /*
1759     * The dollar sign isn't followed by a variable name.
1760     * replace the TCL_TOKEN_VARIABLE token with a
1761     * TCL_TOKEN_TEXT token for the dollar sign.
1762     */
1763    
1764     justADollarSign:
1765     tokenPtr = &parsePtr->tokenPtr[varIndex];
1766     tokenPtr->type = TCL_TOKEN_TEXT;
1767     tokenPtr->size = 1;
1768     tokenPtr->numComponents = 0;
1769     return TCL_OK;
1770    
1771     error:
1772     Tcl_FreeParse(parsePtr);
1773     return TCL_ERROR;
1774     }
1775    
1776     /*
1777     *----------------------------------------------------------------------
1778     *
1779     * Tcl_ParseVar --
1780     *
1781     * Given a string starting with a $ sign, parse off a variable
1782     * name and return its value.
1783     *
1784     * Results:
1785     * The return value is the contents of the variable given by
1786     * the leading characters of string. If termPtr isn't NULL,
1787     * *termPtr gets filled in with the address of the character
1788     * just after the last one in the variable specifier. If the
1789     * variable doesn't exist, then the return value is NULL and
1790     * an error message will be left in interp's result.
1791     *
1792     * Side effects:
1793     * None.
1794     *
1795     *----------------------------------------------------------------------
1796     */
1797    
1798     char *
1799     Tcl_ParseVar(interp, string, termPtr)
1800     Tcl_Interp *interp; /* Context for looking up variable. */
1801     register char *string; /* String containing variable name.
1802     * First character must be "$". */
1803     char **termPtr; /* If non-NULL, points to word to fill
1804     * in with character just after last
1805     * one in the variable specifier. */
1806    
1807     {
1808     Tcl_Parse parse;
1809     register Tcl_Obj *objPtr;
1810    
1811     if (Tcl_ParseVarName(interp, string, -1, &parse, 0) != TCL_OK) {
1812     return NULL;
1813     }
1814    
1815     if (termPtr != NULL) {
1816     *termPtr = string + parse.tokenPtr->size;
1817     }
1818     if (parse.numTokens == 1) {
1819     /*
1820     * There isn't a variable name after all: the $ is just a $.
1821     */
1822    
1823     return "$";
1824     }
1825    
1826     objPtr = Tcl_EvalTokens(interp, parse.tokenPtr, parse.numTokens);
1827     if (objPtr == NULL) {
1828     return NULL;
1829     }
1830    
1831     /*
1832     * At this point we should have an object containing the value of
1833     * a variable. Just return the string from that object.
1834     */
1835    
1836     #ifdef TCL_COMPILE_DEBUG
1837     if (objPtr->refCount < 2) {
1838     panic("Tcl_ParseVar got temporary object from Tcl_EvalTokens");
1839     }
1840     #endif /*TCL_COMPILE_DEBUG*/
1841     TclDecrRefCount(objPtr);
1842     return TclGetString(objPtr);
1843     }
1844    
1845     /*
1846     *----------------------------------------------------------------------
1847     *
1848     * Tcl_ParseBraces --
1849     *
1850     * Given a string in braces such as a Tcl command argument or a string
1851     * value in a Tcl expression, this procedure parses the string and
1852     * returns information about the parse.
1853     *
1854     * Results:
1855     * The return value is TCL_OK if the string was parsed successfully and
1856     * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
1857     * an error message is left in its result. On a successful return,
1858     * tokenPtr and numTokens fields of parsePtr are filled in with
1859     * information about the string that was parsed. Other fields in
1860     * parsePtr are undefined. termPtr is set to point to the character
1861     * just after the last one in the braced string.
1862     *
1863     * Side effects:
1864     * If there is insufficient space in parsePtr to hold all the
1865     * information about the command, then additional space is
1866     * malloc-ed. If the procedure returns TCL_OK then the caller must
1867     * eventually invoke Tcl_FreeParse to release any additional space
1868     * that was allocated.
1869     *
1870     *----------------------------------------------------------------------
1871     */
1872    
1873     int
1874     Tcl_ParseBraces(interp, string, numBytes, parsePtr, append, termPtr)
1875     Tcl_Interp *interp; /* Interpreter to use for error reporting;
1876     * if NULL, then no error message is
1877     * provided. */
1878     char *string; /* String containing the string in braces.
1879     * The first character must be '{'. */
1880     int numBytes; /* Total number of bytes in string. If < 0,
1881     * the string consists of all bytes up to
1882     * the first null character. */
1883     register Tcl_Parse *parsePtr;
1884     /* Structure to fill in with information
1885     * about the string. */
1886     int append; /* Non-zero means append tokens to existing
1887     * information in parsePtr; zero means
1888     * ignore existing tokens in parsePtr and
1889     * reinitialize it. */
1890     char **termPtr; /* If non-NULL, points to word in which to
1891     * store a pointer to the character just
1892     * after the terminating '}' if the parse
1893     * was successful. */
1894    
1895     {
1896     char utfBytes[TCL_UTF_MAX]; /* For result of backslash substitution. */
1897     Tcl_Token *tokenPtr;
1898     register char *src, *end;
1899     int startIndex, level, length;
1900    
1901     if ((numBytes >= 0) || (string == NULL)) {
1902     end = string + numBytes;
1903     } else {
1904     end = string + strlen(string);
1905     }
1906    
1907     if (!append) {
1908     parsePtr->numWords = 0;
1909     parsePtr->tokenPtr = parsePtr->staticTokens;
1910     parsePtr->numTokens = 0;
1911     parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
1912     parsePtr->string = string;
1913     parsePtr->end = end;
1914     parsePtr->interp = interp;
1915     parsePtr->errorType = TCL_PARSE_SUCCESS;
1916     }
1917    
1918     src = string+1;
1919     startIndex = parsePtr->numTokens;
1920    
1921     if (parsePtr->numTokens == parsePtr->tokensAvailable) {
1922     TclExpandTokenArray(parsePtr);
1923     }
1924     tokenPtr = &parsePtr->tokenPtr[startIndex];
1925     tokenPtr->type = TCL_TOKEN_TEXT;
1926     tokenPtr->start = src;
1927     tokenPtr->numComponents = 0;
1928     level = 1;
1929     while (1) {
1930     while (CHAR_TYPE(*src) == TYPE_NORMAL) {
1931     src++;
1932     }
1933     if (*src == '}') {
1934     level--;
1935     if (level == 0) {
1936     break;
1937     }
1938     src++;
1939     } else if (*src == '{') {
1940     level++;
1941     src++;
1942     } else if (*src == '\\') {
1943     Tcl_UtfBackslash(src, &length, utfBytes);
1944     if (src[1] == '\n') {
1945     /*
1946     * A backslash-newline sequence must be collapsed, even
1947     * inside braces, so we have to split the word into
1948     * multiple tokens so that the backslash-newline can be
1949     * represented explicitly.
1950     */
1951    
1952     if ((src + 2) == end) {
1953     parsePtr->incomplete = 1;
1954     }
1955     tokenPtr->size = (src - tokenPtr->start);
1956     if (tokenPtr->size != 0) {
1957     parsePtr->numTokens++;
1958     }
1959     if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) {
1960     TclExpandTokenArray(parsePtr);
1961     }
1962     tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
1963     tokenPtr->type = TCL_TOKEN_BS;
1964     tokenPtr->start = src;
1965     tokenPtr->size = length;
1966     tokenPtr->numComponents = 0;
1967     parsePtr->numTokens++;
1968    
1969     src += length;
1970     tokenPtr++;
1971     tokenPtr->type = TCL_TOKEN_TEXT;
1972     tokenPtr->start = src;
1973     tokenPtr->numComponents = 0;
1974     } else {
1975     src += length;
1976     }
1977     } else if (src == end) {
1978     int openBrace;
1979    
1980     if (interp != NULL) {
1981     Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
1982     }
1983     /*
1984     * Search the source string for a possible open
1985     * brace within the context of a comment. Since we
1986     * aren't performing a full Tcl parse, just look for
1987     * an open brace preceeded by a '<whitspace>#' on
1988     * the same line.
1989     */
1990     openBrace = 0;
1991     while (src > string ) {
1992     switch (*src) {
1993     case '{':
1994     openBrace = 1;
1995     break;
1996     case '\n':
1997     openBrace = 0;
1998     break;
1999     case '#':
2000     if ((openBrace == 1) && (isspace(UCHAR(src[-1])))) {
2001     if (interp != NULL) {
2002     Tcl_AppendResult(interp,
2003     ": possible unbalanced brace in comment",
2004     (char *) NULL);
2005     }
2006     openBrace = -1;
2007     break;
2008     }
2009     break;
2010     }
2011     if (openBrace == -1) {
2012     break;
2013     }
2014     src--;
2015     }
2016     parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
2017     parsePtr->term = string;
2018     parsePtr->incomplete = 1;
2019     goto error;
2020     } else {
2021     src++;
2022     }
2023     }
2024    
2025     /*
2026     * Decide if we need to finish emitting a partially-finished token.
2027     * There are 3 cases:
2028     * {abc \newline xyz} or {xyz} - finish emitting "xyz" token
2029     * {abc \newline} - don't emit token after \newline
2030     * {} - finish emitting zero-sized token
2031     * The last case ensures that there is a token (even if empty) that
2032     * describes the braced string.
2033     */
2034    
2035     if ((src != tokenPtr->start)
2036     || (parsePtr->numTokens == startIndex)) {
2037     tokenPtr->size = (src - tokenPtr->start);
2038     parsePtr->numTokens++;
2039     }
2040     if (termPtr != NULL) {
2041     *termPtr = src+1;
2042     }
2043     return TCL_OK;
2044    
2045     error:
2046     Tcl_FreeParse(parsePtr);
2047     return TCL_ERROR;
2048     }
2049    
2050     /*
2051     *----------------------------------------------------------------------
2052     *
2053     * Tcl_ParseQuotedString --
2054     *
2055     * Given a double-quoted string such as a quoted Tcl command argument
2056     * or a quoted value in a Tcl expression, this procedure parses the
2057     * string and returns information about the parse.
2058     *
2059     * Results:
2060     * The return value is TCL_OK if the string was parsed successfully and
2061     * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then
2062     * an error message is left in its result. On a successful return,
2063     * tokenPtr and numTokens fields of parsePtr are filled in with
2064     * information about the string that was parsed. Other fields in
2065     * parsePtr are undefined. termPtr is set to point to the character
2066     * just after the quoted string's terminating close-quote.
2067     *
2068     * Side effects:
2069     * If there is insufficient space in parsePtr to hold all the
2070     * information about the command, then additional space is
2071     * malloc-ed. If the procedure returns TCL_OK then the caller must
2072     * eventually invoke Tcl_FreeParse to release any additional space
2073     * that was allocated.
2074     *
2075     *----------------------------------------------------------------------
2076     */
2077    
2078     int
2079     Tcl_ParseQuotedString(interp, string, numBytes, parsePtr, append, termPtr)
2080     Tcl_Interp *interp; /* Interpreter to use for error reporting;
2081     * if NULL, then no error message is
2082     * provided. */
2083     char *string; /* String containing the quoted string.
2084     * The first character must be '"'. */
2085     int numBytes; /* Total number of bytes in string. If < 0,
2086     * the string consists of all bytes up to
2087     * the first null character. */
2088     register Tcl_Parse *parsePtr;
2089     /* Structure to fill in with information
2090     * about the string. */
2091     int append; /* Non-zero means append tokens to existing
2092     * information in parsePtr; zero means
2093     * ignore existing tokens in parsePtr and
2094     * reinitialize it. */
2095     char **termPtr; /* If non-NULL, points to word in which to
2096     * store a pointer to the character just
2097     * after the quoted string's terminating
2098     * close-quote if the parse succeeds. */
2099     {
2100     char *end;
2101    
2102     if ((numBytes >= 0) || (string == NULL)) {
2103     end = string + numBytes;
2104     } else {
2105     end = string + strlen(string);
2106     }
2107    
2108     if (!append) {
2109     parsePtr->numWords = 0;
2110     parsePtr->tokenPtr = parsePtr->staticTokens;
2111     parsePtr->numTokens = 0;
2112     parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
2113     parsePtr->string = string;
2114     parsePtr->end = end;
2115     parsePtr->interp = interp;
2116     parsePtr->errorType = TCL_PARSE_SUCCESS;
2117     }
2118    
2119     if (ParseTokens(string+1, TYPE_QUOTE, parsePtr) != TCL_OK) {
2120     goto error;
2121     }
2122     if (*parsePtr->term != '"') {
2123     if (interp != NULL) {
2124     Tcl_SetResult(parsePtr->interp, "missing \"", TCL_STATIC);
2125     }
2126     parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
2127     parsePtr->term = string;
2128     parsePtr->incomplete = 1;
2129     goto error;
2130     }
2131     if (termPtr != NULL) {
2132     *termPtr = (parsePtr->term + 1);
2133     }
2134     return TCL_OK;
2135    
2136     error:
2137     Tcl_FreeParse(parsePtr);
2138     return TCL_ERROR;
2139     }
2140    
2141     /*
2142     *----------------------------------------------------------------------
2143     *
2144     * CommandComplete --
2145     *
2146     * This procedure is shared by TclCommandComplete and
2147     * Tcl_ObjCommandcoComplete; it does all the real work of seeing
2148     * whether a script is complete
2149     *
2150     * Results:
2151     * 1 is returned if the script is complete, 0 if there are open
2152     * delimiters such as " or (. 1 is also returned if there is a
2153     * parse error in the script other than unmatched delimiters.
2154     *
2155     * Side effects:
2156     * None.
2157     *
2158     *----------------------------------------------------------------------
2159     */
2160    
2161     static int
2162     CommandComplete(script, length)
2163     char *script; /* Script to check. */
2164     int length; /* Number of bytes in script. */
2165     {
2166     Tcl_Parse parse;
2167     char *p, *end;
2168     int result;
2169    
2170     p = script;
2171     end = p + length;
2172     while (Tcl_ParseCommand((Tcl_Interp *) NULL, p, end - p, 0, &parse)
2173     == TCL_OK) {
2174     p = parse.commandStart + parse.commandSize;
2175     if (*p == 0) {
2176     break;
2177     }
2178     Tcl_FreeParse(&parse);
2179     }
2180     if (parse.incomplete) {
2181     result = 0;
2182     } else {
2183     result = 1;
2184     }
2185     Tcl_FreeParse(&parse);
2186     return result;
2187     }
2188    
2189     /*
2190     *----------------------------------------------------------------------
2191     *
2192     * Tcl_CommandComplete --
2193     *
2194     * Given a partial or complete Tcl script, this procedure
2195     * determines whether the script is complete in the sense
2196     * of having matched braces and quotes and brackets.
2197     *
2198     * Results:
2199     * 1 is returned if the script is complete, 0 otherwise.
2200     * 1 is also returned if there is a parse error in the script
2201     * other than unmatched delimiters.
2202     *
2203     * Side effects:
2204     * None.
2205     *
2206     *----------------------------------------------------------------------
2207     */
2208    
2209     int
2210     Tcl_CommandComplete(script)
2211     char *script; /* Script to check. */
2212     {
2213     return CommandComplete(script, (int) strlen(script));
2214     }
2215    
2216     /*
2217     *----------------------------------------------------------------------
2218     *
2219     * TclObjCommandComplete --
2220     *
2221     * Given a partial or complete Tcl command in a Tcl object, this
2222     * procedure determines whether the command is complete in the sense of
2223     * having matched braces and quotes and brackets.
2224     *
2225     * Results:
2226     * 1 is returned if the command is complete, 0 otherwise.
2227     *
2228     * Side effects:
2229     * None.
2230     *
2231     *----------------------------------------------------------------------
2232     */
2233    
2234     int
2235     TclObjCommandComplete(objPtr)
2236     Tcl_Obj *objPtr; /* Points to object holding script
2237     * to check. */
2238     {
2239     char *script;
2240     int length;
2241    
2242     script = Tcl_GetStringFromObj(objPtr, &length);
2243     return CommandComplete(script, length);
2244     }
2245    
2246     /*
2247     *----------------------------------------------------------------------
2248     *
2249     * TclIsLocalScalar --
2250     *
2251     * Check to see if a given string is a legal scalar variable
2252     * name with no namespace qualifiers or substitutions.
2253     *
2254     * Results:
2255     * Returns 1 if the variable is a local scalar.
2256     *
2257     * Side effects:
2258     * None.
2259     *
2260     *----------------------------------------------------------------------
2261     */
2262    
2263     int
2264     TclIsLocalScalar(src, len)
2265     CONST char *src;
2266     int len;
2267     {
2268     CONST char *p;
2269     CONST char *lastChar = src + (len - 1);
2270    
2271     for (p = src; p <= lastChar; p++) {
2272     if ((CHAR_TYPE(*p) != TYPE_NORMAL) &&
2273     (CHAR_TYPE(*p) != TYPE_COMMAND_END)) {
2274     /*
2275     * TCL_COMMAND_END is returned for the last character
2276     * of the string. By this point we know it isn't
2277     * an array or namespace reference.
2278     */
2279    
2280     return 0;
2281     }
2282     if (*p == '(') {
2283     if (*lastChar == ')') { /* we have an array element */
2284     return 0;
2285     }
2286     } else if (*p == ':') {
2287     if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
2288     return 0;
2289     }
2290     }
2291     }
2292    
2293     return 1;
2294     }
2295    
2296    
2297     /* $History: tclparse.c $
2298     *
2299     * ***************** Version 1 *****************
2300     * User: Dtashley Date: 1/02/01 Time: 1:37a
2301     * Created in $/IjuScripter, IjuConsole/Source/Tcl Base
2302     * Initial check-in.
2303     */
2304    
2305     /* End of TCLPARSE.C */

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25