tcl/generic/tclParse.c

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