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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 70958 byte(s) 
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 /*$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:keywords Header
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25