diff options
Diffstat (limited to 'generic/tclParse.c')
| -rw-r--r-- | generic/tclParse.c | 1677 |
1 files changed, 869 insertions, 808 deletions
diff --git a/generic/tclParse.c b/generic/tclParse.c index fbf1d65..53b2021 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1,58 +1,56 @@ -/* +/* * tclParse.c -- * - * This file contains procedures that parse Tcl scripts. They - * do so in a general-purpose fashion that can be used for many - * different purposes, including compilation, direct execution, - * code analysis, etc. + * This file contains functions that parse Tcl scripts. They do so in a + * general-purpose fashion that can be used for many different purposes, + * including compilation, direct execution, code analysis, etc. * * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 Ajuba Solutions. * Contributions from Don Porter, NIST, 2002. (not subject to US copyright) * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclParse.c,v 1.42 2005/05/10 18:34:46 kennykb Exp $ + * RCS: @(#) $Id: tclParse.c,v 1.43 2005/07/21 14:38:50 dkf Exp $ */ #include "tclInt.h" /* - * The following table provides parsing information about each possible - * 8-bit character. The table is designed to be referenced with either - * signed or unsigned characters, so it has 384 entries. The first 128 - * entries correspond to negative character values, the next 256 correspond - * to positive character values. The last 128 entries are identical to the - * first 128. The table is always indexed with a 128-byte offset (the 128th - * entry corresponds to a character value of 0). - * - * The macro CHAR_TYPE is used to index into the table and return - * information about its character argument. The following return - * values are defined. - * - * TYPE_NORMAL - All characters that don't have special significance - * to the Tcl parser. - * TYPE_SPACE - The character is a whitespace character other - * than newline. - * TYPE_COMMAND_END - Character is newline or semicolon. - * TYPE_SUBS - Character begins a substitution or has other - * special meaning in ParseTokens: backslash, dollar - * sign, or open bracket. - * TYPE_QUOTE - Character is a double quote. - * TYPE_CLOSE_PAREN - Character is a right parenthesis. - * TYPE_CLOSE_BRACK - Character is a right square bracket. - * TYPE_BRACE - Character is a curly brace (either left or right). + * The following table provides parsing information about each possible 8-bit + * character. The table is designed to be referenced with either signed or + * unsigned characters, so it has 384 entries. The first 128 entries + * correspond to negative character values, the next 256 correspond to + * positive character values. The last 128 entries are identical to the first + * 128. The table is always indexed with a 128-byte offset (the 128th entry + * corresponds to a character value of 0). + * + * The macro CHAR_TYPE is used to index into the table and return information + * about its character argument. The following return values are defined. + * + * TYPE_NORMAL - All characters that don't have special significance to + * the Tcl parser. + * TYPE_SPACE - The character is a whitespace character other than + * newline. + * TYPE_COMMAND_END - Character is newline or semicolon. + * TYPE_SUBS - Character begins a substitution or has other special + * meaning in ParseTokens: backslash, dollar sign, or + * open bracket. + * TYPE_QUOTE - Character is a double quote. + * TYPE_CLOSE_PAREN - Character is a right parenthesis. + * TYPE_CLOSE_BRACK - Character is a right square bracket. + * TYPE_BRACE - Character is a curly brace (either left or right). */ -#define TYPE_NORMAL 0 -#define TYPE_SPACE 0x1 -#define TYPE_COMMAND_END 0x2 -#define TYPE_SUBS 0x4 -#define TYPE_QUOTE 0x8 -#define TYPE_CLOSE_PAREN 0x10 -#define TYPE_CLOSE_BRACK 0x20 -#define TYPE_BRACE 0x40 +#define TYPE_NORMAL 0 +#define TYPE_SPACE 0x1 +#define TYPE_COMMAND_END 0x2 +#define TYPE_SUBS 0x4 +#define TYPE_QUOTE 0x8 +#define TYPE_CLOSE_PAREN 0x10 +#define TYPE_CLOSE_BRACK 0x20 +#define TYPE_BRACE 0x40 #define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)] @@ -170,16 +168,16 @@ static CONST char charTypeTable[] = { }; /* - * Prototypes for local procedures defined in this file: + * Prototypes for local functions defined in this file: */ static int CommandComplete _ANSI_ARGS_((CONST char *script, int numBytes)); -static int ParseComment _ANSI_ARGS_((CONST char *src, int numBytes, - Tcl_Parse *parsePtr)); +static int ParseComment _ANSI_ARGS_((CONST char *src, + int numBytes, Tcl_Parse *parsePtr)); static int ParseTokens _ANSI_ARGS_((CONST char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr)); - + /* *---------------------------------------------------------------------- * @@ -200,9 +198,9 @@ void TclParseInit(interp, string, numBytes, parsePtr) Tcl_Interp *interp; /* Interpreter to use for error reporting */ CONST char *string; /* String to be parsed. */ - int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + int numBytes; /* Total number of bytes in string. If < 0, + * the script consists of all bytes up to the + * first null character. */ Tcl_Parse *parsePtr; /* Points to struct to initialize */ { parsePtr->numWords = 0; @@ -216,63 +214,59 @@ TclParseInit(interp, string, numBytes, parsePtr) parsePtr->incomplete = 0; parsePtr->errorType = TCL_PARSE_SUCCESS; } + /* *---------------------------------------------------------------------- * * Tcl_ParseCommand -- * - * Given a string, this procedure parses the first Tcl command - * in the string and returns information about the structure of - * the command. + * Given a string, this function parses the first Tcl command in the + * string and returns information about the structure of the command. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs - * and interp isn't NULL then an error message is left in - * its result. On a successful return, parsePtr is filled in - * with information about the command that was parsed. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, parsePtr + * is filled in with information about the command that was parsed. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* First character of string containing - * one or more Tcl commands. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* First character of string containing one or + * more Tcl commands. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the script consists of all bytes up to - * the first null character. */ + * the script consists of all bytes up to the + * first null character. */ int nested; /* Non-zero means this is a nested command: - * close bracket should be considered - * a command terminator. If zero, then close + * close bracket should be considered a + * command terminator. If zero, then close * bracket has no special meaning. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the parsed command; any previous - * information in the structure is - * ignored. */ + /* Structure to fill in with information about + * the parsed command; any previous + * information in the structure is ignored. */ { - register CONST char *src; /* Points to current character - * in the command. */ + register CONST char *src; /* Points to current character in the + * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ int wordIndex; /* Index of word token for current word. */ - int terminators; /* CHAR_TYPE bits that indicate the end - * of a command. */ + int terminators; /* CHAR_TYPE bits that indicate the end of a + * command. */ CONST char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ int scanned; - + if ((start == NULL) && (numBytes>0)) { if (interp != NULL) { Tcl_SetResult(interp, "can't parse a NULL pointer", TCL_STATIC); @@ -299,7 +293,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) */ scanned = ParseComment(start, numBytes, parsePtr); - src = (start + scanned); numBytes -= scanned; + src = (start + scanned); + numBytes -= scanned; if (numBytes == 0) { if (nested) { parsePtr->incomplete = nested; @@ -307,8 +302,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) } /* - * The following loop parses the words of the command, one word - * in each iteration through the loop. + * The following loop parses the words of the command, one word in each + * iteration through the loop. */ parsePtr->commandStart = src; @@ -332,7 +327,8 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; if (numBytes == 0) { parsePtr->term = src; break; @@ -348,17 +344,18 @@ Tcl_ParseCommand(interp, start, numBytes, nested, parsePtr) /* * At this point the word can have one of four forms: something - * enclosed in quotes, something enclosed in braces, and - * expanding word, or an unquoted word (anything else). + * enclosed in quotes, something enclosed in braces, and expanding + * word, or an unquoted word (anything else). */ -parseWord: + parseWord: if (*src == '"') { if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; } else if (*src == '{') { static char expPfx[] = "expand"; CONST size_t expPfxLen = sizeof(expPfx) - 1; @@ -369,15 +366,15 @@ parseWord: parsePtr, 1, &termPtr) != TCL_OK) { goto error; } - src = termPtr; numBytes = parsePtr->end - src; + src = termPtr; + numBytes = parsePtr->end - src; - /* - * Check whether the braces contained - * the word expansion prefix. + /* + * Check whether the braces contained the word expansion prefix. */ expPtr = &parsePtr->tokenPtr[expIdx]; - if ( (expPfxLen == (size_t) expPtr->size) + if ((expPfxLen == (size_t) expPtr->size) /* Same length as prefix */ && (0 == expandWord) /* Haven't seen prefix already */ @@ -397,21 +394,21 @@ parseWord: } } else { /* - * This is an unquoted word. Call ParseTokens and let it do - * all of the work. + * This is an unquoted word. Call ParseTokens and let it do all of + * the work. */ if (ParseTokens(src, numBytes, TYPE_SPACE|terminators, TCL_SUBST_ALL, parsePtr) != TCL_OK) { goto error; } - src = parsePtr->term; numBytes = parsePtr->end - src; + src = parsePtr->term; + numBytes = parsePtr->end - src; } /* - * Finish filling in the token for the word and check for the - * special case of a word consisting of a single range of - * literal text. + * Finish filling in the token for the word and check for the special + * case of a word consisting of a single range of literal text. */ tokenPtr = &parsePtr->tokenPtr[wordIndex]; @@ -426,15 +423,15 @@ parseWord: } /* - * Do two additional checks: (a) make sure we're really at the - * end of a word (there might have been garbage left after a - * quoted or braced word), and (b) check for the end of the - * command. + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. */ scanned = TclParseWhiteSpace(src, numBytes, parsePtr, &type); if (scanned) { - src += scanned; numBytes -= scanned; + src += scanned; + numBytes -= scanned; continue; } @@ -444,10 +441,10 @@ parseWord: } if ((type & terminators) != 0) { parsePtr->term = src; - src++; + src++; break; } - if (src[-1] == '"') { + if (src[-1] == '"') { if (interp != NULL) { Tcl_SetResult(interp, "extra characters after close-quote", TCL_STATIC); @@ -467,48 +464,49 @@ parseWord: parsePtr->commandSize = src - parsePtr->commandStart; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * TclParseWhiteSpace -- * - * Scans up to numBytes bytes starting at src, consuming white - * space as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming white space as + * defined by Tcl's parsing rules. * * Results: - * Returns the number of bytes recognized as white space. Records - * at parsePtr, information about the parse. Records at typePtr - * the character type of the non-whitespace character that terminated - * the scan. + * Returns the number of bytes recognized as white space. Records at + * parsePtr, information about the parse. Records at typePtr the + * character type of the non-whitespace character that terminated the + * scan. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ - char *typePtr; /* Points to location to store character - * type of character that ends run - * of whitespace */ + * Updated if parsing indicates an incomplete + * command. */ + char *typePtr; /* Points to location to store character type + * of character that ends run of whitespace */ { register char type = TYPE_NORMAL; register CONST char *p = src; while (1) { while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) { - numBytes--; p++; + numBytes--; + p++; } if (numBytes && (type & TYPE_SUBS)) { if (*p != '\\') { @@ -538,31 +536,30 @@ TclParseWhiteSpace(src, numBytes, parsePtr, typePtr) * * TclParseHex -- * - * Scans a hexadecimal number as a Tcl_UniChar value. - * (e.g., for parsing \x and \u escape sequences). - * At most numBytes bytes are scanned. + * Scans a hexadecimal number as a Tcl_UniChar value (e.g., for parsing + * \x and \u escape sequences). At most numBytes bytes are scanned. * * Results: - * The numeric value is stored in *resultPtr. - * Returns the number of bytes consumed. + * The numeric value is stored in *resultPtr. Returns the number of bytes + * consumed. * * Notes: - * Relies on the following properties of the ASCII - * character set, with which UTF-8 is compatible: + * Relies on the following properties of the ASCII character set, with + * which UTF-8 is compatible: * - * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' - * occupy consecutive code points, and '0' < 'A' < 'a'. + * The digits '0' .. '9' and the letters 'A' .. 'Z' and 'a' .. 'z' occupy + * consecutive code points, and '0' < 'A' < 'a'. * *---------------------------------------------------------------------- */ + int TclParseHex(src, numBytes, resultPtr) CONST char *src; /* First character to parse. */ int numBytes; /* Max number of byes to scan */ - Tcl_UniChar *resultPtr; /* Points to storage provided by - * caller where the Tcl_UniChar - * resulting from the conversion is - * to be written. */ + Tcl_UniChar *resultPtr; /* Points to storage provided by caller where + * the Tcl_UniChar resulting from the + * conversion is to be written. */ { Tcl_UniChar result = 0; register CONST char *p = src; @@ -595,33 +592,33 @@ TclParseHex(src, numBytes, resultPtr) * * TclParseBackslash -- * - * Scans up to numBytes bytes starting at src, consuming a - * backslash sequence as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a backslash + * sequence as defined by Tcl's parsing rules. * * Results: * Records at readPtr the number of bytes making up the backslash - * sequence. Records at dst the UTF-8 encoded equivalent of - * that backslash sequence. Returns the number of bytes written - * to dst, at most TCL_UTF_MAX. Either readPtr or dst may be - * NULL, if the results are not needed, but the return value is - * the same either way. + * sequence. Records at dst the UTF-8 encoded equivalent of that + * backslash sequence. Returns the number of bytes written to dst, at + * most TCL_UTF_MAX. Either readPtr or dst may be NULL, if the results + * are not needed, but the return value is the same either way. * * Side effects: * None. * *---------------------------------------------------------------------- */ + int TclParseBackslash(src, numBytes, readPtr, dst) - CONST char * src; /* Points to the backslash character of a - * a backslash sequence */ - int numBytes; /* Max number of bytes to scan */ - int *readPtr; /* NULL, or points to storage where the - * number of bytes scanned should be written. */ - char *dst; /* NULL, or points to buffer where the UTF-8 - * encoding of the backslash sequence is to be - * written. At most TCL_UTF_MAX bytes will be - * written there. */ + CONST char *src; /* Points to the backslash character of a a + * backslash sequence. */ + int numBytes; /* Max number of bytes to scan. */ + int *readPtr; /* NULL, or points to storage where the number + * of bytes scanned should be written. */ + char *dst; /* NULL, or points to buffer where the UTF-8 + * encoding of the backslash sequence is to be + * written. At most TCL_UTF_MAX bytes will be + * written there. */ { register CONST char *p = src+1; Tcl_UniChar result; @@ -636,11 +633,14 @@ TclParseBackslash(src, numBytes, readPtr, dst) } if (dst == NULL) { - dst = buf; + dst = buf; } if (numBytes == 1) { - /* Can only scan the backslash. Return it. */ + /* + * Can only scan the backslash, so return it. + */ + result = '\\'; count = 1; goto done; @@ -648,105 +648,117 @@ TclParseBackslash(src, numBytes, readPtr, dst) count = 2; switch (*p) { - /* - * Note: in the conversions below, use absolute values (e.g., - * 0xa) rather than symbolic values (e.g. \n) that get converted - * by the compiler. It's possible that compilers on some - * platforms will do the symbolic conversions differently, which - * could result in non-portable Tcl scripts. - */ - - case 'a': - result = 0x7; - break; - case 'b': - result = 0x8; - break; - case 'f': - result = 0xc; - break; - case 'n': - result = 0xa; - break; - case 'r': - result = 0xd; - break; - case 't': - result = 0x9; - break; - case 'v': - result = 0xb; - break; - case 'x': - count += TclParseHex(p+1, numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "x". */ - result = 'x'; - } else { - /* Keep only the last byte (2 hex digits) */ - result = (unsigned char) result; - } - break; - case 'u': - count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); - if (count == 2) { - /* No hexadigits -> This is just "u". */ - result = 'u'; + /* + * Note: in the conversions below, use absolute values (e.g., 0xa) + * rather than symbolic values (e.g. \n) that get converted by the + * compiler. It's possible that compilers on some platforms will do + * the symbolic conversions differently, which could result in + * non-portable Tcl scripts. + */ + + case 'a': + result = 0x7; + break; + case 'b': + result = 0x8; + break; + case 'f': + result = 0xc; + break; + case 'n': + result = 0xa; + break; + case 'r': + result = 0xd; + break; + case 't': + result = 0x9; + break; + case 'v': + result = 0xb; + break; + case 'x': + count += TclParseHex(p+1, numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "x". + */ + + result = 'x'; + } else { + /* + * Keep only the last byte (2 hex digits). + */ + result = (unsigned char) result; + } + break; + case 'u': + count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-1, &result); + if (count == 2) { + /* + * No hexadigits -> This is just "u". + */ + result = 'u'; + } + break; + case '\n': + count--; + do { + p++; + count++; + } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); + result = ' '; + break; + case 0: + result = '\\'; + count = 1; + break; + default: + /* + * Check for an octal number \oo?o? + */ + + if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ + result = (unsigned char)(*p - '0'); + p++; + if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; } - break; - case '\n': - count--; - do { - p++; count++; - } while ((count < numBytes) && ((*p == ' ') || (*p == '\t'))); - result = ' '; - break; - case 0: - result = '\\'; - count = 1; - break; - default: - /* - * Check for an octal number \oo?o? - */ - if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) { /* INTL: digit */ - result = (unsigned char)(*p - '0'); - p++; - if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 3; - result = (unsigned char)((result << 3) + (*p - '0')); - p++; - if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ - || (UCHAR(*p) >= '8')) { - break; - } - count = 4; - result = (unsigned char)((result << 3) + (*p - '0')); - break; - } - /* - * We have to convert here in case the user has put a - * backslash in front of a multi-byte utf-8 character. - * While this means nothing special, we shouldn't break up - * a correct utf-8 character. [Bug #217987] test subst-3.2 - */ - if (Tcl_UtfCharComplete(p, numBytes - 1)) { - count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ - } else { - char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, p, (size_t) (numBytes - 1)); - utfBytes[numBytes - 1] = '\0'; - count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + count = 3; + result = (unsigned char)((result << 3) + (*p - '0')); + p++; + if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */ + || (UCHAR(*p) >= '8')) { + break; } - break; + count = 4; + result = (unsigned char)((result << 3) + (*p - '0')); + break; + } + + /* + * We have to convert here in case the user has put a backslash in + * front of a multi-byte utf-8 character. While this means nothing + * special, we shouldn't break up a correct utf-8 character. [Bug + * #217987] test subst-3.2 + */ + + if (Tcl_UtfCharComplete(p, numBytes - 1)) { + count = Tcl_UtfToUniChar(p, &result) + 1; /* +1 for '\' */ + } else { + char utfBytes[TCL_UTF_MAX]; + + memcpy(utfBytes, p, (size_t) (numBytes - 1)); + utfBytes[numBytes - 1] = '\0'; + count = Tcl_UtfToUniChar(utfBytes, &result) + 1; + } + break; } - done: + done: if (readPtr != NULL) { - *readPtr = count; + *readPtr = count; } return Tcl_UniCharToUtf((int) result, dst); } @@ -756,57 +768,66 @@ TclParseBackslash(src, numBytes, readPtr, dst) * * ParseComment -- * - * Scans up to numBytes bytes starting at src, consuming a - * Tcl comment as defined by Tcl's parsing rules. + * Scans up to numBytes bytes starting at src, consuming a Tcl comment as + * defined by Tcl's parsing rules. * * Results: - * Records in parsePtr information about the parse. Returns the - * number of bytes consumed. + * Records in parsePtr information about the parse. Returns the number of + * bytes consumed. * * Side effects: * None. * *---------------------------------------------------------------------- */ + static int ParseComment(src, numBytes, parsePtr) CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ Tcl_Parse *parsePtr; /* Information about parse in progress. - * Updated if parsing indicates - * an incomplete command. */ + * Updated if parsing indicates an incomplete + * command. */ { register CONST char *p = src; while (numBytes) { char type; int scanned; + do { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++,numBytes--)); + if ((numBytes == 0) || (*p != '#')) { break; } if (parsePtr->commentStart == NULL) { parsePtr->commentStart = p; } + while (numBytes) { if (*p == '\\') { scanned = TclParseWhiteSpace(p, numBytes, parsePtr, &type); if (scanned) { - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } else { /* - * General backslash substitution in comments isn't - * part of the formal spec, but test parse-15.47 - * and history indicate that it has been the de facto - * rule. Don't change it now. + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. */ + TclParseBackslash(p, numBytes, &scanned, NULL); - p += scanned; numBytes -= scanned; + p += scanned; + numBytes -= scanned; } } else { - p++; numBytes--; + p++; + numBytes--; if (p[-1] == '\n') { break; } @@ -816,27 +837,25 @@ ParseComment(src, numBytes, parsePtr) } return (p - src); } - + /* *---------------------------------------------------------------------- * * ParseTokens -- * - * This procedure forms the heart of the Tcl parser. It parses one - * or more tokens from a string, up to a termination point - * specified by the caller. This procedure is used to parse - * unquoted command words (those not in quotes or braces), words in - * quotes, and array indices for variables. No more than numBytes - * bytes will be scanned. + * This function forms the heart of the Tcl parser. It parses one or more + * tokens from a string, up to a termination point specified by the + * caller. This function is used to parse unquoted command words (those + * not in quotes or braces), words in quotes, and array indices for + * variables. No more than numBytes bytes will be scanned. * * Results: - * Tokens are added to parsePtr and parsePtr->term is filled in - * with the address of the character that terminated the parse (the - * first one whose CHAR_TYPE matched mask or the character at - * parsePtr->end). The return value is TCL_OK if the parse - * completed successfully and TCL_ERROR otherwise. If a parse - * error occurs and parsePtr->interp isn't NULL, then an error - * message is left in the interpreter's result. + * Tokens are added to parsePtr and parsePtr->term is filled in with the + * address of the character that terminated the parse (the first one + * whose CHAR_TYPE matched mask or the character at parsePtr->end). The + * return value is TCL_OK if the parse completed successfully and + * TCL_ERROR otherwise. If a parse error occurs and parsePtr->interp is + * not NULL, then an error message is left in the interpreter's result. * * Side effects: * None. @@ -848,19 +867,19 @@ static int ParseTokens(src, numBytes, mask, flags, parsePtr) register CONST char *src; /* First character to parse. */ register int numBytes; /* Max number of bytes to scan. */ - int flags; /* OR-ed bits indicating what substitutions - to perform: TCL_SUBST_COMMANDS, - TCL_SUBST_VARIABLES, and + int flags; /* OR-ed bits indicating what substitutions to + perform: TCL_SUBST_COMMANDS, + TCL_SUBST_VARIABLES, and TCL_SUBST_BACKSLASHES */ - int mask; /* Specifies when to stop parsing. The - * parse stops at the first unquoted - * character whose CHAR_TYPE contains - * any of the bits in mask. */ + int mask; /* Specifies when to stop parsing. The parse + * stops at the first unquoted character whose + * CHAR_TYPE contains any of the bits in + * mask. */ Tcl_Parse *parsePtr; /* Information about parse in progress. * Updated with additional tokens and * termination information. */ { - char type; + char type; int originalTokens, varToken; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); @@ -869,10 +888,10 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) Tcl_Parse nested; /* - * Each iteration through the following loop adds one token of - * type TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or - * TCL_TOKEN_VARIABLE to parsePtr. For TCL_TOKEN_VARIABLE tokens, - * additional tokens are added for the parsed variable name. + * Each iteration through the following loop adds one token of type + * TCL_TOKEN_TEXT, TCL_TOKEN_BS, TCL_TOKEN_COMMAND, or TCL_TOKEN_VARIABLE + * to parsePtr. For TCL_TOKEN_VARIABLE tokens, additional tokens are added + * for the parsed variable name. */ originalTokens = parsePtr->numTokens; @@ -886,11 +905,11 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) if ((type & TYPE_SUBS) == 0) { /* - * This is a simple range of characters. Scan to find the end - * of the range. + * This is a simple range of characters. Scan to find the end of + * the range. */ - while ((++src, --numBytes) + while ((++src, --numBytes) && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) { /* empty loop */ } @@ -902,12 +921,14 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * This is a variable reference. Call Tcl_ParseVarName to do - * all the dirty work of parsing the name. + * This is a variable reference. Call Tcl_ParseVarName to do all + * the dirty work of parsing the name. */ varToken = parsePtr->numTokens; @@ -922,16 +943,19 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* - * Command substitution. Call Tcl_ParseCommand recursively - * (and repeatedly) to parse the nested command(s), then - * throw away the parse information. + * Command substitution. Call Tcl_ParseCommand recursively (and + * repeatedly) to parse the nested command(s), then throw away the + * parse information. */ - src++; numBytes--; + src++; + numBytes--; while (1) { if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1, &nested) != TCL_OK) { @@ -954,8 +978,8 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) /* * Check for the closing ']' that ends the command - * substitution. It must have been the last character of - * the parsed command. + * substitution. It must have been the last character of the + * parsed command. */ if ((nested.term < parsePtr->end) && (*nested.term == ']') @@ -965,7 +989,7 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) if (numBytes == 0) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, - "missing close-bracket", TCL_STATIC); + "missing close-bracket", TCL_STATIC); } parsePtr->errorType = TCL_PARSE_MISSING_BRACKET; parsePtr->term = tokenPtr->start; @@ -981,19 +1005,26 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } + /* * Backslash substitution. */ + TclParseBackslash(src, numBytes, &tokenPtr->size, NULL); if (tokenPtr->size == 1) { - /* Just a backslash, due to end of string */ + /* + * Just a backslash, due to end of string. + */ + tokenPtr->type = TCL_TOKEN_TEXT; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; continue; } @@ -1003,9 +1034,9 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) } /* - * Note: backslash-newline is special in that it is - * treated the same as a space character would be. This - * means that it could terminate the token. + * Note: backslash-newline is special in that it is treated + * the same as a space character would be. This means that it + * could terminate the token. */ if (mask & TYPE_SPACE) { @@ -1024,17 +1055,18 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; parsePtr->numTokens++; - src++; numBytes--; + src++; + numBytes--; } else { Tcl_Panic("ParseTokens encountered unknown character"); } } if (parsePtr->numTokens == originalTokens) { /* - * There was nothing in this range of text. Add an empty token - * for the empty range, so that there is always at least one - * token added. + * There was nothing in this range of text. Add an empty token for + * the empty range, so that there is always at least one token added. */ + if (parsePtr->numTokens == parsePtr->tokensAvailable) { TclExpandTokenArray(parsePtr); } @@ -1042,7 +1074,7 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) tokenPtr->start = src; tokenPtr->numComponents = 0; - finishToken: + finishToken: tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 0; parsePtr->numTokens++; @@ -1050,59 +1082,59 @@ ParseTokens(src, numBytes, mask, flags, parsePtr) parsePtr->term = src; return TCL_OK; } - + /* *---------------------------------------------------------------------- * * Tcl_FreeParse -- * - * This procedure is invoked to free any dynamic storage that may - * have been allocated by a previous call to Tcl_ParseCommand. + * This function is invoked to free any dynamic storage that may have + * been allocated by a previous call to Tcl_ParseCommand. * * Results: * None. * * Side effects: - * If there is any dynamically allocated memory in *parsePtr, - * it is freed. + * If there is any dynamically allocated memory in *parsePtr, it is + * freed. * *---------------------------------------------------------------------- */ void Tcl_FreeParse(parsePtr) - Tcl_Parse *parsePtr; /* Structure that was filled in by a - * previous call to Tcl_ParseCommand. */ + Tcl_Parse *parsePtr; /* Structure that was filled in by a previous + * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { ckfree((char *) parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } - + /* *---------------------------------------------------------------------- * * TclExpandTokenArray -- * - * This procedure is invoked when the current space for tokens in - * a Tcl_Parse structure fills up; it allocates memory to grow the - * token array + * This function is invoked when the current space for tokens in a + * Tcl_Parse structure fills up; it allocates memory to grow the token + * array * * Results: * None. * * Side effects: - * Memory is allocated for a new larger token array; the memory - * for the old array is freed, if it had been dynamically allocated. + * Memory is allocated for a new larger token array; the memory for the + * old array is freed, if it had been dynamically allocated. * *---------------------------------------------------------------------- */ void TclExpandTokenArray(parsePtr) - Tcl_Parse *parsePtr; /* Parse structure whose token space - * has overflowed. */ + Tcl_Parse *parsePtr; /* Parse structure whose token space has + * overflowed. */ { int newCount; Tcl_Token *newPtr; @@ -1117,52 +1149,49 @@ TclExpandTokenArray(parsePtr) parsePtr->tokenPtr = newPtr; parsePtr->tokensAvailable = newCount; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVarName -- * - * Given a string starting with a $ sign, parse off a variable - * name and return information about the parse. No more than - * numBytes bytes will be scanned. + * Given a string starting with a $ sign, parse off a variable name and + * return information about the parse. No more than numBytes bytes will + * be scanned. * * Results: - * The return value is TCL_OK if the command was parsed - * successfully and TCL_ERROR otherwise. If an error occurs and - * interp isn't NULL then an error message is left in its result. - * On a successful return, tokenPtr and numTokens fields of - * parsePtr are filled in with information about the variable name - * that was parsed. The "size" field of the first new token gives - * the total number of bytes in the variable name. Other fields in - * parsePtr are undefined. + * The return value is TCL_OK if the command was parsed successfully and + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the variable name that was parsed. The "size" field of the first new + * token gives the total number of bytes in the variable name. Other + * fields in parsePtr are undefined. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ CONST char *start; /* Start of variable substitution string. * First character must be "$". */ - register int numBytes; /* Total number of bytes in string. If < 0, + register int numBytes; /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ - Tcl_Parse *parsePtr; /* Structure to fill in with information - * about the variable name. */ + Tcl_Parse *parsePtr; /* Structure to fill in with information about + * the variable name. */ int append; /* Non-zero means append tokens to existing * information in parsePtr; zero means ignore - * existing tokens in parsePtr and reinitialize - * it. */ + * existing tokens in parsePtr and + * reinitialize it. */ { Tcl_Token *tokenPtr; register CONST char *src; @@ -1183,9 +1212,8 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) } /* - * Generate one token for the variable, an additional token for the - * name, plus any number of additional tokens for the index, if - * there is one. + * Generate one token for the variable, an additional token for the name, + * plus any number of additional tokens for the index, if there is one. */ src = start; @@ -1198,7 +1226,8 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) varIndex = parsePtr->numTokens; parsePtr->numTokens++; tokenPtr++; - src++; numBytes--; + src++; + numBytes--; if (numBytes == 0) { goto justADollarSign; } @@ -1208,29 +1237,30 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) /* * The name of the variable can have three forms: - * 1. The $ sign is followed by an open curly brace. Then - * the variable name is everything up to the next close - * curly brace, and the variable is a scalar variable. - * 2. The $ sign is not followed by an open curly brace. Then - * the variable name is everything up to the next - * character that isn't a letter, digit, or underscore. - * :: sequences are also considered part of the variable - * name, in order to support namespaces. If the following - * character is an open parenthesis, then the information - * between parentheses is the array element name. - * 3. The $ sign is followed by something that isn't a letter, - * digit, or underscore: in this case, there is no variable - * name and the token is just "$". + * 1. The $ sign is followed by an open curly brace. Then the variable + * name is everything up to the next close curly brace, and the + * variable is a scalar variable. + * 2. The $ sign is not followed by an open curly brace. Then the + * variable name is everything up to the next character that isn't a + * letter, digit, or underscore. :: sequences are also considered part + * of the variable name, in order to support namespaces. If the + * following character is an open parenthesis, then the information + * between parentheses is the array element name. + * 3. The $ sign is followed by something that isn't a letter, digit, or + * underscore: in this case, there is no variable name and the token is + * just "$". */ if (*src == '{') { - src++; numBytes--; + src++; + numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; while (numBytes && (*src != '}')) { - numBytes--; src++; + numBytes--; + src++; } if (numBytes == 0) { if (interp != NULL) { @@ -1250,24 +1280,29 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; + while (numBytes) { if (Tcl_UtfCharComplete(src, numBytes)) { - offset = Tcl_UtfToUniChar(src, &ch); + offset = Tcl_UtfToUniChar(src, &ch); } else { char utfBytes[TCL_UTF_MAX]; + memcpy(utfBytes, src, (size_t) numBytes); utfBytes[numBytes] = '\0'; - offset = Tcl_UtfToUniChar(utfBytes, &ch); + offset = Tcl_UtfToUniChar(utfBytes, &ch); } c = UCHAR(ch); if (isalnum(c) || (c == '_')) { /* INTL: ISO only, UCHAR. */ - src += offset; numBytes -= offset; + src += offset; + numBytes -= offset; continue; } if ((c == ':') && (numBytes != 1) && (src[1] == ':')) { - src += 2; numBytes -= 2; + src += 2; + numBytes -= 2; while (numBytes && (*src == ':')) { - src++; numBytes--; + src++; + numBytes--; } continue; } @@ -1277,6 +1312,7 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) /* * Support for empty array names here. */ + array = (numBytes && (*src == '(')); tokenPtr->size = src - tokenPtr->start; if ((tokenPtr->size == 0) && !array) { @@ -1285,17 +1321,16 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) parsePtr->numTokens++; if (array) { /* - * This is a reference to an array element. Call - * ParseTokens recursively to parse the element name, - * since it could contain any number of substitutions. + * This is a reference to an array element. Call ParseTokens + * recursively to parse the element name, since it could contain + * any number of substitutions. */ if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { goto error; } - if ((parsePtr->term == (src + numBytes)) - || (*parsePtr->term != ')')) { + if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')) { if (parsePtr->interp != NULL) { Tcl_SetResult(parsePtr->interp, "missing )", TCL_STATIC); @@ -1314,38 +1349,37 @@ Tcl_ParseVarName(interp, start, numBytes, parsePtr, append) return TCL_OK; /* - * The dollar sign isn't followed by a variable name. - * replace the TCL_TOKEN_VARIABLE token with a - * TCL_TOKEN_TEXT token for the dollar sign. + * The dollar sign isn't followed by a variable name. Replace the + * TCL_TOKEN_VARIABLE token with a TCL_TOKEN_TEXT token for the dollar + * sign. */ - justADollarSign: + justADollarSign: tokenPtr = &parsePtr->tokenPtr[varIndex]; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->size = 1; tokenPtr->numComponents = 0; return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_ParseVar -- * - * Given a string starting with a $ sign, parse off a variable - * name and return its value. + * Given a string starting with a $ sign, parse off a variable name and + * return its value. * * Results: - * The return value is the contents of the variable given by - * the leading characters of string. If termPtr isn't NULL, - * *termPtr gets filled in with the address of the character - * just after the last one in the variable specifier. If the - * variable doesn't exist, then the return value is NULL and - * an error message will be left in interp's result. + * The return value is the contents of the variable given by the leading + * characters of string. If termPtr isn't NULL, *termPtr gets filled in + * with the address of the character just after the last one in the + * variable specifier. If the variable doesn't exist, then the return + * value is NULL and an error message will be left in interp's result. * * Side effects: * None. @@ -1361,7 +1395,6 @@ Tcl_ParseVar(interp, start, termPtr) CONST char **termPtr; /* If non-NULL, points to word to fill * in with character just after last * one in the variable specifier. */ - { Tcl_Parse parse; register Tcl_Obj *objPtr; @@ -1389,14 +1422,14 @@ Tcl_ParseVar(interp, start, termPtr) objPtr = Tcl_GetObjResult(interp); /* - * At this point we should have an object containing the value of - * a variable. Just return the string from that object. + * At this point we should have an object containing the value of a + * variable. Just return the string from that object. * * This should have returned the object for the user to manage, but - * instead we have some weak reference to the string value in the - * object, which is why we make sure the object exists after resetting - * the result. This isn't ideal, but it's the best we can do with the - * current documented interface. -- hobbs + * instead we have some weak reference to the string value in the object, + * which is why we make sure the object exists after resetting the result. + * This isn't ideal, but it's the best we can do with the current + * documented interface. -- hobbs */ if (!Tcl_IsShared(objPtr)) { @@ -1405,57 +1438,55 @@ Tcl_ParseVar(interp, start, termPtr) Tcl_ResetResult(interp); return TclGetString(objPtr); } - + /* *---------------------------------------------------------------------- * * Tcl_ParseBraces -- * * Given a string in braces such as a Tcl command argument or a string - * value in a Tcl expression, this procedure parses the string and - * returns information about the parse. No more than numBytes bytes - * will be scanned. + * value in a Tcl expression, this function parses the string and returns + * information about the parse. No more than numBytes bytes will be + * scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the last one in the braced string. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the last one in + * the braced string. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* Start of string enclosed in braces. - * The first character must be {'. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of string enclosed in braces. The + * first character must be {'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the terminating '}' if the parse - * was successful. */ + * store a pointer to the character just after + * the terminating '}' if the parse was + * successful. */ { Tcl_Token *tokenPtr; @@ -1491,175 +1522,178 @@ Tcl_ParseBraces(interp, start, numBytes, parsePtr, append, termPtr) } } if (numBytes == 0) { - register int openBrace = 0; + goto missingBraceError; + } - parsePtr->errorType = TCL_PARSE_MISSING_BRACE; - parsePtr->term = start; - parsePtr->incomplete = 1; - if (interp == NULL) { + switch (*src) { + case '{': + level++; + break; + case '}': + if (--level == 0) { /* - * Skip straight to the exit code since we have no - * interpreter to put error message in. + * Decide if we need to finish emitting a partially-finished + * token. There are 3 cases: + * {abc \newline xyz} or {xyz} + * - finish emitting "xyz" token + * {abc \newline} + * - don't emit token after \newline + * {} - finish emitting zero-sized token + * + * The last case ensures that there is a token (even if empty) + * that describes the braced string. */ - goto error; - } - - Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); - - /* - * Guess if the problem is due to comments by searching - * the source string for a possible open brace within the - * context of a comment. Since we aren't performing a - * full Tcl parse, just look for an open brace preceded - * by a '<whitespace>#' on the same line. - */ - for (; src > start; src--) { - switch (*src) { - case '{': - openBrace = 1; - break; - case '\n': - openBrace = 0; - break; - case '#' : - if (openBrace && (isspace(UCHAR(src[-1])))) { - Tcl_AppendResult(interp, - ": possible unbalanced brace in comment", - (char *) NULL); - goto error; - } - break; + if ((src != tokenPtr->start) + || (parsePtr->numTokens == startIndex)) { + tokenPtr->size = (src - tokenPtr->start); + parsePtr->numTokens++; + } + if (termPtr != NULL) { + *termPtr = src+1; } + return TCL_OK; } + break; + case '\\': + TclParseBackslash(src, numBytes, &length, NULL); + if ((length > 1) && (src[1] == '\n')) { + /* + * A backslash-newline sequence must be collapsed, even inside + * braces, so we have to split the word into multiple tokens + * so that the backslash-newline can be represented + * explicitly. + */ - error: - Tcl_FreeParse(parsePtr); - return TCL_ERROR; + if (numBytes == 2) { + parsePtr->incomplete = 1; + } + tokenPtr->size = (src - tokenPtr->start); + if (tokenPtr->size != 0) { + parsePtr->numTokens++; + } + if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { + TclExpandTokenArray(parsePtr); + } + tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; + tokenPtr->type = TCL_TOKEN_BS; + tokenPtr->start = src; + tokenPtr->size = length; + tokenPtr->numComponents = 0; + parsePtr->numTokens++; + + src += length - 1; + numBytes -= length - 1; + tokenPtr++; + tokenPtr->type = TCL_TOKEN_TEXT; + tokenPtr->start = src + 1; + tokenPtr->numComponents = 0; + } else { + src += length - 1; + numBytes -= length - 1; + } + break; } - switch (*src) { + } + + missingBraceError: + parsePtr->errorType = TCL_PARSE_MISSING_BRACE; + parsePtr->term = start; + parsePtr->incomplete = 1; + if (interp == NULL) { + /* + * Skip straight to the exit code since we have no interpreter to put + * error message in. + */ + + goto error; + } + + Tcl_SetResult(interp, "missing close-brace", TCL_STATIC); + + /* + * Guess if the problem is due to comments by searching the source string + * for a possible open brace within the context of a comment. Since we + * aren't performing a full Tcl parse, just look for an open brace + * preceded by a '<whitespace>#' on the same line. + */ + + { + register int openBrace = 0; + + for (; src > start; src--) { + switch (*src) { case '{': - level++; + openBrace = 1; break; - case '}': - if (--level == 0) { - - /* - * Decide if we need to finish emitting a - * partially-finished token. There are 3 cases: - * {abc \newline xyz} or {xyz} - * - finish emitting "xyz" token - * {abc \newline} - * - don't emit token after \newline - * {} - finish emitting zero-sized token - * - * The last case ensures that there is a token - * (even if empty) that describes the braced string. - */ - - if ((src != tokenPtr->start) - || (parsePtr->numTokens == startIndex)) { - tokenPtr->size = (src - tokenPtr->start); - parsePtr->numTokens++; - } - if (termPtr != NULL) { - *termPtr = src+1; - } - return TCL_OK; - } + case '\n': + openBrace = 0; break; - case '\\': - TclParseBackslash(src, numBytes, &length, NULL); - if ((length > 1) && (src[1] == '\n')) { - /* - * A backslash-newline sequence must be collapsed, even - * inside braces, so we have to split the word into - * multiple tokens so that the backslash-newline can be - * represented explicitly. - */ - - if (numBytes == 2) { - parsePtr->incomplete = 1; - } - tokenPtr->size = (src - tokenPtr->start); - if (tokenPtr->size != 0) { - parsePtr->numTokens++; - } - if ((parsePtr->numTokens+1) >= parsePtr->tokensAvailable) { - TclExpandTokenArray(parsePtr); - } - tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens]; - tokenPtr->type = TCL_TOKEN_BS; - tokenPtr->start = src; - tokenPtr->size = length; - tokenPtr->numComponents = 0; - parsePtr->numTokens++; - - src += length - 1; - numBytes -= length - 1; - tokenPtr++; - tokenPtr->type = TCL_TOKEN_TEXT; - tokenPtr->start = src + 1; - tokenPtr->numComponents = 0; - } else { - src += length - 1; - numBytes -= length - 1; + case '#' : + if (openBrace && (isspace(UCHAR(src[-1])))) { + Tcl_AppendResult(interp, + ": possible unbalanced brace in comment", + (char *) NULL); + goto error; } break; + } } } -} + error: + Tcl_FreeParse(parsePtr); + return TCL_ERROR; +} + /* *---------------------------------------------------------------------- * * Tcl_ParseQuotedString -- * - * Given a double-quoted string such as a quoted Tcl command argument - * or a quoted value in a Tcl expression, this procedure parses the - * string and returns information about the parse. No more than - * numBytes bytes will be scanned. + * Given a double-quoted string such as a quoted Tcl command argument or + * a quoted value in a Tcl expression, this function parses the string + * and returns information about the parse. No more than numBytes bytes + * will be scanned. * * Results: * The return value is TCL_OK if the string was parsed successfully and - * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then - * an error message is left in its result. On a successful return, - * tokenPtr and numTokens fields of parsePtr are filled in with - * information about the string that was parsed. Other fields in - * parsePtr are undefined. termPtr is set to point to the character - * just after the quoted string's terminating close-quote. + * TCL_ERROR otherwise. If an error occurs and interp isn't NULL then an + * error message is left in its result. On a successful return, tokenPtr + * and numTokens fields of parsePtr are filled in with information about + * the string that was parsed. Other fields in parsePtr are undefined. + * termPtr is set to point to the character just after the quoted + * string's terminating close-quote. * * Side effects: - * If there is insufficient space in parsePtr to hold all the - * information about the command, then additional space is - * malloc-ed. If the procedure returns TCL_OK then the caller must - * eventually invoke Tcl_FreeParse to release any additional space - * that was allocated. + * If there is insufficient space in parsePtr to hold all the information + * about the command, then additional space is malloc-ed. If the function + * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to + * release any additional space that was allocated. * *---------------------------------------------------------------------- */ int Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) - Tcl_Interp *interp; /* Interpreter to use for error reporting; - * if NULL, then no error message is - * provided. */ - CONST char *start; /* Start of the quoted string. - * The first character must be '"'. */ + Tcl_Interp *interp; /* Interpreter to use for error reporting; if + * NULL, then no error message is provided. */ + CONST char *start; /* Start of the quoted string. The first + * character must be '"'. */ register int numBytes; /* Total number of bytes in string. If < 0, - * the string consists of all bytes up to - * the first null character. */ + * the string consists of all bytes up to the + * first null character. */ register Tcl_Parse *parsePtr; - /* Structure to fill in with information - * about the string. */ + /* Structure to fill in with information about + * the string. */ int append; /* Non-zero means append tokens to existing - * information in parsePtr; zero means - * ignore existing tokens in parsePtr and + * information in parsePtr; zero means ignore + * existing tokens in parsePtr and * reinitialize it. */ CONST char **termPtr; /* If non-NULL, points to word in which to - * store a pointer to the character just - * after the quoted string's terminating - * close-quote if the parse succeeds. */ + * store a pointer to the character just after + * the quoted string's terminating close-quote + * if the parse succeeds. */ { if ((numBytes == 0) || (start == NULL)) { return TCL_ERROR; @@ -1671,7 +1705,7 @@ Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) if (!append) { TclParseInit(interp, start, numBytes, parsePtr); } - + if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL, parsePtr)) { goto error; @@ -1690,35 +1724,34 @@ Tcl_ParseQuotedString(interp, start, numBytes, parsePtr, append, termPtr) } return TCL_OK; - error: + error: Tcl_FreeParse(parsePtr); return TCL_ERROR; } - + /* *---------------------------------------------------------------------- * * Tcl_SubstObj -- * - * This function performs the substitutions specified on the - * given string as described in the user documentation for the - * "subst" Tcl command. + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. * * Results: - * A Tcl_Obj* containing the substituted string, or NULL to - * indicate that an error occurred. + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Obj * Tcl_SubstObj(interp, objPtr, flags) - Tcl_Interp *interp; /* Interpreter in which substitution occurs */ - Tcl_Obj *objPtr; /* The value to be substituted */ - int flags; /* What substitutions to do */ + Tcl_Interp *interp; /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr; /* The value to be substituted. */ + int flags; /* What substitutions to do. */ { int length, tokensLeft, code; Tcl_Parse parse; @@ -1730,28 +1763,27 @@ Tcl_SubstObj(interp, objPtr, flags) TclParseInit(interp, p, length, &parse); /* - * First parse the string rep of objPtr, as if it were enclosed - * as a "-quoted word in a normal Tcl command. Honor flags that - * selectively inhibit types of substitution. + * First parse the string rep of objPtr, as if it were enclosed as a + * "-quoted word in a normal Tcl command. Honor flags that selectively + * inhibit types of substitution. */ if (TCL_OK != ParseTokens(p, length, /* mask */ 0, flags, &parse)) { - /* - * There was a parse error. Save the error message for - * possible reporting later. + * There was a parse error. Save the error message for possible + * reporting later. */ errMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errMsg); /* - * We need to re-parse to get the portion of the string we can - * [subst] before the parse error. Sadly, all the Tcl_Token's - * created by the first parse attempt are gone, freed according to the - * public spec for the Tcl_Parse* routines. The only clue we have - * is parse.term, which points to either the unmatched opener, or - * to characters that follow a close brace or close quote. + * We need to re-parse to get the portion of the string we can [subst] + * before the parse error. Sadly, all the Tcl_Token's created by the + * first parse attempt are gone, freed according to the public spec + * for the Tcl_Parse* routines. The only clue we have is parse.term, + * which points to either the unmatched opener, or to characters that + * follow a close brace or close quote. * * Call ParseTokens again, working on the string up to parse.term. * Keep repeating until we get a good parse on a prefix. @@ -1765,123 +1797,134 @@ Tcl_SubstObj(interp, objPtr, flags) parse.errorType = TCL_PARSE_SUCCESS; } while (TCL_OK != ParseTokens(p, parse.end - p, 0, flags, &parse)); - /* The good parse will have to be followed by {, (, or [. */ + /* + * The good parse will have to be followed by {, (, or [. + */ + switch (*parse.term) { - case '{': + case '{': + /* + * Parse error was a missing } in a ${varname} variable + * substitution at the toplevel. We will subst everything up to + * that broken variable substitution before reporting the parse + * error. Substituting the leftover '$' will have no side-effects, + * so the current token stream is fine. + */ + break; + + case '(': + /* + * Parse error was during the parsing of the index part of an + * array variable substitution at the toplevel. + */ + + if (*(parse.term - 1) == '$') { /* - * Parse error was a missing } in a ${varname} variable - * substitution at the toplevel. We will subst everything - * up to that broken variable substitution before reporting - * the parse error. Substituting the leftover '$' will - * have no side-effects, so the current token stream is fine. + * Special case where removing the array index left us with + * just a dollar sign (array variable with name the empty + * string as its name), instead of with a scalar variable + * reference. + * + * As in the previous case, existing token stream is OK. */ - break; - case '(': + } else { /* - * Parse error was during the parsing of the index part of - * an array variable substitution at the toplevel. + * The current parse includes a successful parse of a scalar + * variable substitution where there should have been an array + * variable substitution. We remove that mistaken part of the + * parse before moving on. A scalar variable substitution is + * two tokens. */ - if (*(parse.term - 1) == '$') { - /* - * Special case where removing the array index left - * us with just a dollar sign (array variable with - * name the empty string as its name), instead of - * with a scalar variable reference. - * - * As in the previous case, existing token stream is OK. - */ - } else { - /* The current parse includes a successful parse of a - * scalar variable substitution where there should have - * been an array variable substitution. We remove that - * mistaken part of the parse before moving on. A scalar - * variable substitution is two tokens. - */ - Tcl_Token *varTokenPtr = - parse.tokenPtr + parse.numTokens - 2; - - if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { - Tcl_Panic("Tcl_SubstObj: programming error"); - } - parse.numTokens -= 2; + + Tcl_Token *varTokenPtr = + parse.tokenPtr + parse.numTokens - 2; + + if (varTokenPtr->type != TCL_TOKEN_VARIABLE) { + Tcl_Panic("Tcl_SubstObj: programming error"); } - break; - case '[': + if (varTokenPtr[1].type != TCL_TOKEN_TEXT) { + Tcl_Panic("Tcl_SubstObj: programming error"); + } + parse.numTokens -= 2; + } + break; + case '[': + /* + * Parse error occurred during parsing of a toplevel command + * substitution. + */ + + parse.end = p + length; + p = parse.term + 1; + length = parse.end - p; + if (length == 0) { + /* + * No commands, just an unmatched [. As in previous cases, + * existing token stream is OK. + */ + } else { /* - * Parse error occurred during parsing of a toplevel - * command substitution. + * We want to add the parsing of as many commands as we can + * within that substitution until we reach the actual parse + * error. We'll do additional parsing to determine what + * length to claim for the final TCL_TOKEN_COMMAND token. */ - parse.end = p + length; - p = parse.term + 1; - length = parse.end - p; - if (length == 0) { - /* - * No commands, just an unmatched [. - * As in previous cases, existing token stream is OK. - */ - } else { - /* - * We want to add the parsing of as many commands as we - * can within that substitution until we reach the - * actual parse error. We'll do additional parsing to - * determine what length to claim for the final - * TCL_TOKEN_COMMAND token. - */ - Tcl_Token *tokenPtr; - Tcl_Parse nested; - CONST char *lastTerm = parse.term; - - while (TCL_OK == - Tcl_ParseCommand(NULL, p, length, 0, &nested)) { - Tcl_FreeParse(&nested); - p = nested.term + (nested.term < nested.end); - length = nested.end - p; - if ((length == 0) && (nested.term == nested.end)) { - /* - * If we run out of string, blame the missing - * close bracket on the last command, and do - * not evaluate it during substitution. - */ - break; - } - lastTerm = nested.term; - } + Tcl_Token *tokenPtr; + Tcl_Parse nested; + CONST char *lastTerm = parse.term; - if (lastTerm == parse.term) { + while (TCL_OK == + Tcl_ParseCommand(NULL, p, length, 0, &nested)) { + Tcl_FreeParse(&nested); + p = nested.term + (nested.term < nested.end); + length = nested.end - p; + if ((length == 0) && (nested.term == nested.end)) { /* - * Parse error in first command. No commands - * to subst, add no more tokens. + * If we run out of string, blame the missing close + * bracket on the last command, and do not evaluate it + * during substitution. */ + break; } + lastTerm = nested.term; + } + if (lastTerm == parse.term) { /* - * Create a command substitution token for whatever - * commands got parsed. + * Parse error in first command. No commands to subst, + * add no more tokens. */ + break; + } - if (parse.numTokens == parse.tokensAvailable) { - TclExpandTokenArray(&parse); - } - tokenPtr = &parse.tokenPtr[parse.numTokens]; - tokenPtr->start = parse.term; - tokenPtr->numComponents = 0; - tokenPtr->type = TCL_TOKEN_COMMAND; - tokenPtr->size = lastTerm - tokenPtr->start + 1; - parse.numTokens++; + /* + * Create a command substitution token for whatever commands + * got parsed. + */ + + if (parse.numTokens == parse.tokensAvailable) { + TclExpandTokenArray(&parse); } - break; + tokenPtr = &parse.tokenPtr[parse.numTokens]; + tokenPtr->start = parse.term; + tokenPtr->numComponents = 0; + tokenPtr->type = TCL_TOKEN_COMMAND; + tokenPtr->size = lastTerm - tokenPtr->start + 1; + parse.numTokens++; + } + break; - default: - Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); + default: + Tcl_Panic("bad parse in Tcl_SubstObj: %c", p[length]); } } - /* Next, substitute the parsed tokens just as in normal Tcl evaluation */ + /* + * Next, substitute the parsed tokens just as in normal Tcl evaluation. + */ + endTokenPtr = parse.tokenPtr + parse.numTokens; tokensLeft = parse.numTokens; code = TclSubstTokens(interp, endTokenPtr - tokensLeft, tokensLeft, @@ -1895,20 +1938,21 @@ Tcl_SubstObj(interp, objPtr, flags) } return Tcl_GetObjResult(interp); } + result = Tcl_NewObj(); while (1) { switch (code) { - case TCL_ERROR: - Tcl_FreeParse(&parse); - Tcl_DecrRefCount(result); - if (errMsg != NULL) { - Tcl_DecrRefCount(errMsg); - } - return NULL; - case TCL_BREAK: - tokensLeft = 0; /* Halt substitution */ - default: - Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); + case TCL_ERROR: + Tcl_FreeParse(&parse); + Tcl_DecrRefCount(result); + if (errMsg != NULL) { + Tcl_DecrRefCount(errMsg); + } + return NULL; + case TCL_BREAK: + tokensLeft = 0; /* Halt substitution */ + default: + Tcl_AppendObjToObj(result, Tcl_GetObjResult(interp)); } if (tokensLeft == 0) { @@ -1929,23 +1973,22 @@ Tcl_SubstObj(interp, objPtr, flags) &tokensLeft); } } - + /* *---------------------------------------------------------------------- * * TclSubstTokens -- * - * Accepts an array of count Tcl_Token's, and creates a result - * value in the interp from concatenating the results of - * performing Tcl substitution on each Tcl_Token. Substitution - * is interrupted if any non-TCL_OK completion code arises. + * Accepts an array of count Tcl_Token's, and creates a result value in + * the interp from concatenating the results of performing Tcl + * substitution on each Tcl_Token. Substitution is interrupted if any + * non-TCL_OK completion code arises. * * Results: - * The return value is a standard Tcl completion code. The - * result in interp is the substituted value, or an error message - * if TCL_ERROR is returned. If tokensLeftPtr is not NULL, then - * it points to an int where the number of tokens remaining to - * be processed is written. + * The return value is a standard Tcl completion code. The result in + * interp is the substituted value, or an error message if TCL_ERROR is + * returned. If tokensLeftPtr is not NULL, then it points to an int where + * the number of tokens remaining to be processed is written. * * Side effects: * Can be anything, depending on the types of substitution done. @@ -1955,13 +1998,13 @@ Tcl_SubstObj(interp, objPtr, flags) int TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) - Tcl_Interp *interp; /* Interpreter in which to lookup - * variables, execute nested commands, - * and report errors. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to evaluate and concatenate. */ - int count; /* Number of tokens to consider at tokenPtr. - * Must be at least 1. */ + Tcl_Interp *interp; /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ int *tokensLeftPtr; /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ @@ -1971,115 +2014,125 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) /* * Each pass through this loop will substitute one token, and its - * components, if any. The only thing tricky here is that we go to - * some effort to pass Tcl_Obj's through untouched, to avoid string - * copying and Tcl_Obj creation if possible, to aid performance and - * limit shimmering. + * components, if any. The only thing tricky here is that we go to some + * effort to pass Tcl_Obj's through untouched, to avoid string copying and + * Tcl_Obj creation if possible, to aid performance and limit shimmering. * - * Further optimization opportunities might be to check for the - * equivalent of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) - * and omit them. + * Further optimization opportunities might be to check for the equivalent + * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them. */ result = NULL; - for ( ; (count > 0) && (code == TCL_OK); count--, tokenPtr++) { + for (; count>0 && code==TCL_OK ; count--, tokenPtr++) { Tcl_Obj *appendObj = NULL; CONST char *append = NULL; int appendByteLength = 0; char utfCharBytes[TCL_UTF_MAX]; switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - append = tokenPtr->start; - appendByteLength = tokenPtr->size; - break; + case TCL_TOKEN_TEXT: + append = tokenPtr->start; + appendByteLength = tokenPtr->size; + break; - case TCL_TOKEN_BS: { - appendByteLength = Tcl_UtfBackslash(tokenPtr->start, - (int *) NULL, utfCharBytes); - append = utfCharBytes; - break; - } + case TCL_TOKEN_BS: + appendByteLength = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + utfCharBytes); + append = utfCharBytes; + break; - case TCL_TOKEN_COMMAND: { - Interp *iPtr = (Interp *) interp; - iPtr->numLevels++; - code = TclInterpReady(interp); - if (code == TCL_OK) { - code = Tcl_EvalEx(interp, - tokenPtr->start+1, tokenPtr->size-2, 0); - } - iPtr->numLevels--; - appendObj = Tcl_GetObjResult(interp); - break; + case TCL_TOKEN_COMMAND: { + Interp *iPtr = (Interp *) interp; + + iPtr->numLevels++; + code = TclInterpReady(interp); + if (code == TCL_OK) { + code = Tcl_EvalEx(interp, tokenPtr->start+1, tokenPtr->size-2, + 0); } + iPtr->numLevels--; + appendObj = Tcl_GetObjResult(interp); + break; + } - case TCL_TOKEN_VARIABLE: { - Tcl_Obj *arrayIndex = NULL; - Tcl_Obj *varName = NULL; - if (tokenPtr->numComponents > 1) { - /* Subst the index part of an array variable reference */ - code = TclSubstTokens(interp, tokenPtr+2, - tokenPtr->numComponents - 1, NULL); - arrayIndex = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(arrayIndex); - } + case TCL_TOKEN_VARIABLE: { + Tcl_Obj *arrayIndex = NULL; + Tcl_Obj *varName = NULL; - if (code == TCL_OK) { - varName = Tcl_NewStringObj(tokenPtr[1].start, - tokenPtr[1].size); - appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, - TCL_LEAVE_ERR_MSG); - Tcl_DecrRefCount(varName); - if (appendObj == NULL) { - code = TCL_ERROR; - } - } + if (tokenPtr->numComponents > 1) { + /* + * Subst the index part of an array variable reference. + */ - switch (code) { - case TCL_OK: /* Got value */ - case TCL_ERROR: /* Already have error message */ - case TCL_BREAK: /* Will not substitute anyway */ - case TCL_CONTINUE: /* Will not substitute anyway */ - break; - default: - /* All other return codes, we will subst the - * result from the code-throwing evaluation */ - appendObj = Tcl_GetObjResult(interp); - } + code = TclSubstTokens(interp, tokenPtr+2, + tokenPtr->numComponents - 1, NULL); + arrayIndex = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(arrayIndex); + } - if (arrayIndex != NULL) { - Tcl_DecrRefCount(arrayIndex); + if (code == TCL_OK) { + varName = Tcl_NewStringObj(tokenPtr[1].start, + tokenPtr[1].size); + appendObj = Tcl_ObjGetVar2(interp, varName, arrayIndex, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(varName); + if (appendObj == NULL) { + code = TCL_ERROR; } - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; } + switch (code) { + case TCL_OK: /* Got value */ + case TCL_ERROR: /* Already have error message */ + case TCL_BREAK: /* Will not substitute anyway */ + case TCL_CONTINUE: /* Will not substitute anyway */ + break; default: - Tcl_Panic("unexpected token type in TclSubstTokens: %d", - tokenPtr->type); + /* + * All other return codes, we will subst the result from the + * code-throwing evaluation. + */ + + appendObj = Tcl_GetObjResult(interp); + } + + if (arrayIndex != NULL) { + Tcl_DecrRefCount(arrayIndex); + } + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + } + + default: + Tcl_Panic("unexpected token type in TclSubstTokens: %d", + tokenPtr->type); } if ((code == TCL_BREAK) || (code == TCL_CONTINUE)) { - /* Inhibit substitution */ + /* + * Inhibit substitution. + */ continue; } if (result == NULL) { - /* - * First pass through. If we have a Tcl_Obj, just use it. - * If not, create one from our string. + /* + * First pass through. If we have a Tcl_Obj, just use it. If not, + * create one from our string. */ if (appendObj != NULL) { result = appendObj; } else { - result = Tcl_NewStringObj(append, appendByteLength);; + result = Tcl_NewStringObj(append, appendByteLength); } Tcl_IncrRefCount(result); } else { - /* Subsequent passes. Append to result. */ + /* + * Subsequent passes. Append to result. + */ + if (Tcl_IsShared(result)) { Tcl_DecrRefCount(result); result = Tcl_DuplicateObj(result); @@ -2093,7 +2146,7 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) } } - if (code != TCL_ERROR) { /* Keep error message in result! */ + if (code != TCL_ERROR) { /* Keep error message in result! */ if (result != NULL) { Tcl_SetObjResult(interp, result); } else { @@ -2114,14 +2167,14 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) * * CommandComplete -- * - * This procedure is shared by TclCommandComplete and - * Tcl_ObjCommandComplete; it does all the real work of seeing - * whether a script is complete + * This function is shared by TclCommandComplete and + * Tcl_ObjCommandComplete; it does all the real work of seeing whether a + * script is complete * * Results: * 1 is returned if the script is complete, 0 if there are open - * delimiters such as " or (. 1 is also returned if there is a - * parse error in the script other than unmatched delimiters. + * delimiters such as " or (. 1 is also returned if there is a parse + * error in the script other than unmatched delimiters. * * Side effects: * None. @@ -2131,8 +2184,8 @@ TclSubstTokens(interp, tokenPtr, count, tokensLeftPtr) static int CommandComplete(script, numBytes) - CONST char *script; /* Script to check. */ - int numBytes; /* Number of bytes in script. */ + CONST char *script; /* Script to check. */ + int numBytes; /* Number of bytes in script. */ { Tcl_Parse parse; CONST char *p, *end; @@ -2156,20 +2209,20 @@ CommandComplete(script, numBytes) Tcl_FreeParse(&parse); return result; } - + /* *---------------------------------------------------------------------- * * Tcl_CommandComplete -- * - * Given a partial or complete Tcl script, this procedure - * determines whether the script is complete in the sense - * of having matched braces and quotes and brackets. + * Given a partial or complete Tcl script, this function determines + * whether the script is complete in the sense of having matched braces + * and quotes and brackets. * * Results: - * 1 is returned if the script is complete, 0 otherwise. - * 1 is also returned if there is a parse error in the script - * other than unmatched delimiters. + * 1 is returned if the script is complete, 0 otherwise. 1 is also + * returned if there is a parse error in the script other than unmatched + * delimiters. * * Side effects: * None. @@ -2179,19 +2232,19 @@ CommandComplete(script, numBytes) int Tcl_CommandComplete(script) - CONST char *script; /* Script to check. */ + CONST char *script; /* Script to check. */ { return CommandComplete(script, (int) strlen(script)); } - + /* *---------------------------------------------------------------------- * * TclObjCommandComplete -- * - * Given a partial or complete Tcl command in a Tcl object, this - * procedure determines whether the command is complete in the sense of - * having matched braces and quotes and brackets. + * Given a partial or complete Tcl command in a Tcl object, this function + * determines whether the command is complete in the sense of having + * matched braces and quotes and brackets. * * Results: * 1 is returned if the command is complete, 0 otherwise. @@ -2204,8 +2257,8 @@ Tcl_CommandComplete(script) int TclObjCommandComplete(objPtr) - Tcl_Obj *objPtr; /* Points to object holding script - * to check. */ + Tcl_Obj *objPtr; /* Points to object holding script to + * check. */ { CONST char *script; int length; @@ -2213,14 +2266,14 @@ TclObjCommandComplete(objPtr) script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } - + /* *---------------------------------------------------------------------- * * TclIsLocalScalar -- * - * Check to see if a given string is a legal scalar variable - * name with no namespace qualifiers or substitutions. + * Check to see if a given string is a legal scalar variable name with no + * namespace qualifiers or substitutions. * * Results: * Returns 1 if the variable is a local scalar. @@ -2239,13 +2292,13 @@ TclIsLocalScalar(src, len) CONST char *p; CONST char *lastChar = src + (len - 1); - for (p = src; p <= lastChar; p++) { + for (p=src ; p<=lastChar ; p++) { if ((CHAR_TYPE(*p) != TYPE_NORMAL) && (CHAR_TYPE(*p) != TYPE_COMMAND_END)) { /* - * TCL_COMMAND_END is returned for the last character - * of the string. By this point we know it isn't - * an array or namespace reference. + * TCL_COMMAND_END is returned for the last character of the + * string. By this point we know it isn't an array or namespace + * reference. */ return 0; @@ -2260,6 +2313,14 @@ TclIsLocalScalar(src, len) } } } - + return 1; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ |