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

Properties

Name Value
svn:eol-style native
svn:keywords Header
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25