/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tclparse.c
ViewVC logotype

Contents of /sf_code/esrgpcpj/shared/tcl_base/tclparse.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25