--- /dev/null
+/*
+ * tclParse.c --
+ *
+ * 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.
+ */
+
+#include "tclInt.h"
+#include "tclParse.h"
+#include <assert.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).
+ */
+
+const char tclCharTypeTable[] = {
+ /*
+ * Negative character values, from -128 to -1:
+ */
+
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+
+ /*
+ * Positive character values, from 0-127:
+ */
+
+ TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_SPACE, TYPE_COMMAND_END, TYPE_SPACE,
+ TYPE_SPACE, TYPE_SPACE, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL,
+ TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_COMMAND_END,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SUBS,
+ TYPE_SUBS, TYPE_CLOSE_BRACK, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_BRACE,
+ TYPE_NORMAL, TYPE_BRACE, TYPE_NORMAL, TYPE_NORMAL,
+
+ /*
+ * Large unsigned character values, from 128-255:
+ */
+
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+ TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL,
+};
+
+/*
+ * Prototypes for local functions defined in this file:
+ */
+
+static inline int CommandComplete(const char *script, int numBytes);
+static int ParseComment(const char *src, int numBytes,
+ Tcl_Parse *parsePtr);
+static int ParseTokens(const char *src, int numBytes, int mask,
+ int flags, Tcl_Parse *parsePtr);
+static int ParseWhiteSpace(const char *src, int numBytes,
+ int *incompletePtr, char *typePtr);
+static int ParseHex(const char *src, int numBytes,
+ int *resultPtr);
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseInit --
+ *
+ * Initialize the fields of a Tcl_Parse struct.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The Tcl_Parse struct pointed to by parsePtr gets initialized.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclParseInit(
+ Tcl_Interp *interp, /* Interpreter to use for error reporting */
+ const char *start, /* Start of 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. */
+ Tcl_Parse *parsePtr) /* Points to struct to initialize */
+{
+ parsePtr->numWords = 0;
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->string = start;
+ parsePtr->end = start + numBytes;
+ parsePtr->term = parsePtr->end;
+ parsePtr->interp = interp;
+ parsePtr->incomplete = 0;
+ parsePtr->errorType = TCL_PARSE_SUCCESS;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseCommand --
+ *
+ * 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.
+ *
+ * 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 function
+ * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
+ * release any additional space that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseCommand(
+ 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. */
+ int numBytes, /* Total number of bytes in string. If < 0,
+ * 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
+ * bracket has no special meaning. */
+ Tcl_Parse *parsePtr)
+ /* Structure to fill in with information about
+ * the parsed command; any previous
+ * information in the structure is ignored. */
+{
+ 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. */
+ const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to
+ * point to char after terminating one. */
+ int scanned;
+
+ if (numBytes < 0 && start) {
+ numBytes = strlen(start);
+ }
+ TclParseInit(interp, start, numBytes, parsePtr);
+ if ((start == NULL) && (numBytes != 0)) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "can't parse a NULL pointer", -1));
+ }
+ return TCL_ERROR;
+ }
+ parsePtr->commentStart = NULL;
+ parsePtr->commentSize = 0;
+ parsePtr->commandStart = NULL;
+ parsePtr->commandSize = 0;
+ if (nested != 0) {
+ terminators = TYPE_COMMAND_END | TYPE_CLOSE_BRACK;
+ } else {
+ terminators = TYPE_COMMAND_END;
+ }
+
+ /*
+ * Parse any leading space and comments before the first word of the
+ * command.
+ */
+
+ scanned = ParseComment(start, numBytes, parsePtr);
+ src = (start + scanned);
+ numBytes -= scanned;
+ if (numBytes == 0) {
+ if (nested) {
+ parsePtr->incomplete = nested;
+ }
+ }
+
+ /*
+ * The following loop parses the words of the command, one word in each
+ * iteration through the loop.
+ */
+
+ parsePtr->commandStart = src;
+ while (1) {
+ int expandWord = 0;
+
+ /*
+ * Create the token for the word.
+ */
+
+ TclGrowParseTokenArray(parsePtr, 1);
+ wordIndex = parsePtr->numTokens;
+ tokenPtr = &parsePtr->tokenPtr[wordIndex];
+ tokenPtr->type = TCL_TOKEN_WORD;
+
+ /*
+ * Skip white space before the word. Also skip a backslash-newline
+ * sequence: it should be treated just like white space.
+ */
+
+ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
+ src += scanned;
+ numBytes -= scanned;
+ if (numBytes == 0) {
+ parsePtr->term = src;
+ break;
+ }
+ if ((type & terminators) != 0) {
+ parsePtr->term = src;
+ src++;
+ break;
+ }
+ tokenPtr->start = src;
+ parsePtr->numTokens++;
+ parsePtr->numWords++;
+
+ /*
+ * 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).
+ */
+
+ parseWord:
+ if (*src == '"') {
+ if (Tcl_ParseQuotedString(interp, src, numBytes, parsePtr, 1,
+ &termPtr) != TCL_OK) {
+ goto error;
+ }
+ src = termPtr;
+ numBytes = parsePtr->end - src;
+ } else if (*src == '{') {
+ int expIdx = wordIndex + 1;
+ Tcl_Token *expPtr;
+
+ if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1,
+ &termPtr) != TCL_OK) {
+ goto error;
+ }
+ src = termPtr;
+ numBytes = parsePtr->end - src;
+
+ /*
+ * Check whether the braces contained the word expansion prefix
+ * {*}
+ */
+
+ expPtr = &parsePtr->tokenPtr[expIdx];
+ if ((0 == expandWord)
+ /* Haven't seen prefix already */
+ && (1 == parsePtr->numTokens - expIdx)
+ /* Only one token */
+ && (((1 == (size_t) expPtr->size)
+ /* Same length as prefix */
+ && (expPtr->start[0] == '*')))
+ /* Is the prefix */
+ && (numBytes > 0) && (0 == ParseWhiteSpace(termPtr,
+ numBytes, &parsePtr->incomplete, &type))
+ && (type != TYPE_COMMAND_END)
+ /* Non-whitespace follows */) {
+ expandWord = 1;
+ parsePtr->numTokens--;
+ goto parseWord;
+ }
+ } else {
+ /*
+ * 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;
+ }
+
+ /*
+ * 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];
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1);
+ if (expandWord) {
+ int i, isLiteral = 1;
+
+ /*
+ * When a command includes a word that is an expanded literal; for
+ * example, {*}{1 2 3}, the parser performs that expansion
+ * immediately, generating several TCL_TOKEN_SIMPLE_WORDs instead
+ * of a single TCL_TOKEN_EXPAND_WORD that the Tcl_ParseCommand()
+ * caller might have to expand. This notably makes it simpler for
+ * those callers that wish to track line endings, such as those
+ * that implement key parts of TIP 280.
+ *
+ * First check whether the thing to be expanded is a literal,
+ * in the sense of being composed entirely of TCL_TOKEN_TEXT
+ * tokens.
+ */
+
+ for (i = 1; i <= tokenPtr->numComponents; i++) {
+ if (tokenPtr[i].type != TCL_TOKEN_TEXT) {
+ isLiteral = 0;
+ break;
+ }
+ }
+
+ if (isLiteral) {
+ int elemCount = 0, code = TCL_OK, literal = 1;
+ const char *nextElem, *listEnd, *elemStart;
+
+ /*
+ * The word to be expanded is a literal, so determine the
+ * boundaries of the literal string to be treated as a list
+ * and expanded. That literal string starts at
+ * tokenPtr[1].start, and includes all bytes up to, but not
+ * including (tokenPtr[tokenPtr->numComponents].start +
+ * tokenPtr[tokenPtr->numComponents].size)
+ */
+
+ listEnd = (tokenPtr[tokenPtr->numComponents].start +
+ tokenPtr[tokenPtr->numComponents].size);
+ nextElem = tokenPtr[1].start;
+
+ /*
+ * Step through the literal string, parsing and counting list
+ * elements.
+ */
+
+ while (nextElem < listEnd) {
+ int size;
+
+ code = TclFindElement(NULL, nextElem, listEnd - nextElem,
+ &elemStart, &nextElem, &size, &literal);
+ if ((code != TCL_OK) || !literal) {
+ break;
+ }
+ if (elemStart < listEnd) {
+ elemCount++;
+ }
+ }
+
+ if ((code != TCL_OK) || !literal) {
+ /*
+ * Some list element could not be parsed, or is not
+ * present as a literal substring of the script. The
+ * compiler cannot handle list elements that get generated
+ * by a call to TclCopyAndCollapse(). Defer the
+ * handling of this to compile/eval time, where code is
+ * already in place to report the "attempt to expand a
+ * non-list" error or expand lists that require
+ * substitution.
+ */
+
+ tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
+ } else if (elemCount == 0) {
+ /*
+ * We are expanding a literal empty list. This means that
+ * the expanding word completely disappears, leaving no
+ * word generated this pass through the loop. Adjust
+ * accounting appropriately.
+ */
+
+ parsePtr->numWords--;
+ parsePtr->numTokens = wordIndex;
+ } else {
+ /*
+ * Recalculate the number of Tcl_Tokens needed to store
+ * tokens representing the expanded list.
+ */
+
+ const char *listStart;
+ int growthNeeded = wordIndex + 2*elemCount
+ - parsePtr->numTokens;
+
+ parsePtr->numWords += elemCount - 1;
+ if (growthNeeded > 0) {
+ TclGrowParseTokenArray(parsePtr, growthNeeded);
+ tokenPtr = &parsePtr->tokenPtr[wordIndex];
+ }
+ parsePtr->numTokens = wordIndex + 2*elemCount;
+
+ /*
+ * Generate a TCL_TOKEN_SIMPLE_WORD token sequence for
+ * each element of the literal list we are expanding in
+ * place. Take care with the start and size fields of each
+ * token so they point to the right literal characters in
+ * the original script to represent the right expanded
+ * word value.
+ */
+
+ listStart = nextElem = tokenPtr[1].start;
+ while (nextElem < listEnd) {
+ int quoted;
+
+ tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
+ tokenPtr->numComponents = 1;
+
+ tokenPtr++;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->numComponents = 0;
+ TclFindElement(NULL, nextElem, listEnd - nextElem,
+ &(tokenPtr->start), &nextElem,
+ &(tokenPtr->size), NULL);
+
+ quoted = (tokenPtr->start[-1] == '{'
+ || tokenPtr->start[-1] == '"')
+ && tokenPtr->start > listStart;
+ tokenPtr[-1].start = tokenPtr->start - quoted;
+ tokenPtr[-1].size = tokenPtr->start + tokenPtr->size
+ - tokenPtr[-1].start + quoted;
+
+ tokenPtr++;
+ }
+ }
+ } else {
+ /*
+ * The word to be expanded is not a literal, so defer
+ * expansion to compile/eval time by marking with a
+ * TCL_TOKEN_EXPAND_WORD token.
+ */
+
+ tokenPtr->type = TCL_TOKEN_EXPAND_WORD;
+ }
+ } else if ((tokenPtr->numComponents == 1)
+ && (tokenPtr[1].type == TCL_TOKEN_TEXT)) {
+ tokenPtr->type = TCL_TOKEN_SIMPLE_WORD;
+ }
+
+ /*
+ * 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 = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type);
+ if (scanned) {
+ src += scanned;
+ numBytes -= scanned;
+ continue;
+ }
+
+ if (numBytes == 0) {
+ parsePtr->term = src;
+ break;
+ }
+ if ((type & terminators) != 0) {
+ parsePtr->term = src;
+ src++;
+ break;
+ }
+ if (src[-1] == '"') {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-quote", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA;
+ } else {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "extra characters after close-brace", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_BRACE_EXTRA;
+ }
+ parsePtr->term = src;
+ goto error;
+ }
+
+ parsePtr->commandSize = src - parsePtr->commandStart;
+ return TCL_OK;
+
+ error:
+ Tcl_FreeParse(parsePtr);
+ parsePtr->commandSize = parsePtr->end - parsePtr->commandStart;
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIsSpaceProc --
+ *
+ * Report whether byte is in the set of whitespace characters used by
+ * Tcl to separate words in scripts or elements in lists.
+ *
+ * Results:
+ * Returns 1, if byte is in the set, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIsSpaceProc(
+ int byte)
+{
+ return CHAR_TYPE(byte) & (TYPE_SPACE) || byte == '\n';
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIsBareword--
+ *
+ * Report whether byte is one that can be part of a "bareword".
+ * This concept is named in expression parsing, where it determines
+ * what can be a legal function name, but is the same definition used
+ * in determining what variable names can be parsed as variable
+ * substitutions without the benefit of enclosing braces. The set of
+ * ASCII chars that are accepted are the numeric chars ('0'-'9'),
+ * the alphabetic chars ('a'-'z', 'A'-'Z') and underscore ('_').
+ *
+ * Results:
+ * Returns 1, if byte is in the accepted set of chars, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIsBareword(
+ int byte)
+{
+ if (byte < '0' || byte > 'z') {
+ return 0;
+ }
+ if (byte <= '9' || byte >= 'a') {
+ return 1;
+ }
+ if (byte == '_') {
+ return 1;
+ }
+ if (byte < 'A' || byte > 'Z') {
+ return 0;
+ }
+ return 1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseWhiteSpace --
+ *
+ * Scans up to numBytes bytes starting at src, consuming white space
+ * between words 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseWhiteSpace(
+ const char *src, /* First character to parse. */
+ int numBytes, /* Max number of bytes to scan. */
+ int *incompletePtr, /* Set this boolean memory to true if parsing
+ * indicates an incomplete command. */
+ char *typePtr) /* Points to location to store character type
+ * of character that ends run of whitespace */
+{
+ char type = TYPE_NORMAL;
+ const char *p = src;
+
+ while (1) {
+ while (numBytes && ((type = CHAR_TYPE(*p)) & TYPE_SPACE)) {
+ numBytes--;
+ p++;
+ }
+ if (numBytes && (type & TYPE_SUBS)) {
+ if (*p != '\\') {
+ break;
+ }
+ if (--numBytes == 0) {
+ break;
+ }
+ if (p[1] != '\n') {
+ break;
+ }
+ p += 2;
+ if (--numBytes == 0) {
+ *incompletePtr = 1;
+ break;
+ }
+ continue;
+ }
+ break;
+ }
+ *typePtr = type;
+ return (p - src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseAllWhiteSpace --
+ *
+ * Scans up to numBytes bytes starting at src, consuming all white space
+ * including the command-terminating newline characters.
+ *
+ * Results:
+ * Returns the number of bytes recognized as white space.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclParseAllWhiteSpace(
+ const char *src, /* First character to parse. */
+ int numBytes) /* Max number of byes to scan */
+{
+ int dummy;
+ char type;
+ const char *p = src;
+
+ do {
+ int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type);
+
+ p += scanned;
+ numBytes -= scanned;
+ } while (numBytes && (*p == '\n') && (p++, --numBytes));
+ return (p-src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseHex --
+ *
+ * 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.
+ *
+ * Notes:
+ * 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'.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+ParseHex(
+ const char *src, /* First character to parse. */
+ int numBytes, /* Max number of byes to scan */
+ int *resultPtr) /* Points to storage provided by caller where
+ * the character resulting from the
+ * conversion is to be written. */
+{
+ int result = 0;
+ const char *p = src;
+
+ while (numBytes--) {
+ unsigned char digit = UCHAR(*p);
+
+ if (!isxdigit(digit) || (result > 0x10FFF)) {
+ break;
+ }
+
+ p++;
+ result <<= 4;
+
+ if (digit >= 'a') {
+ result |= (10 + digit - 'a');
+ } else if (digit >= 'A') {
+ result |= (10 + digit - 'A');
+ } else {
+ result |= (digit - '0');
+ }
+ }
+
+ *resultPtr = result;
+ return (p - src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclParseBackslash --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclParseBackslash(
+ 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 *p = src+1;
+ int result;
+ int count;
+ char buf[TCL_UTF_MAX] = "";
+
+ if (numBytes == 0) {
+ if (readPtr != NULL) {
+ *readPtr = 0;
+ }
+ return 0;
+ }
+
+ if (dst == NULL) {
+ dst = buf;
+ }
+
+ if (numBytes == 1) {
+ /*
+ * Can only scan the backslash, so return it.
+ */
+
+ result = '\\';
+ count = 1;
+ goto done;
+ }
+
+ 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 += ParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
+ if (count == 2) {
+ /*
+ * No hexdigits -> This is just "x".
+ */
+
+ result = 'x';
+ } else {
+ /*
+ * Keep only the last byte (2 hex digits).
+ */
+ result = UCHAR(result);
+ }
+ break;
+ case 'u':
+ count += ParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result);
+ if (count == 2) {
+ /*
+ * No hexdigits -> This is just "u".
+ */
+ result = 'u';
+#if TCL_UTF_MAX > 3
+ } else if (((result & 0xFC00) == 0xD800) && (count == 6)
+ && (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) {
+ /* If high surrogate is immediately followed by a low surrogate
+ * escape, combine them into one character. */
+ int low;
+ int count2 = ParseHex(p+7, 4, &low);
+ if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) {
+ result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000;
+ count += count2 + 2;
+ }
+#endif
+ }
+ break;
+ case 'U':
+ count += ParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
+ if (count == 2) {
+ /*
+ * No hexdigits -> This is just "U".
+ */
+ result = 'U';
+#if TCL_UTF_MAX > 3
+ } else if ((result & ~0x7FF) == 0xD800) {
+ /* Upper or lower surrogate, not allowed in this syntax. */
+ result = 0xFFFD;
+#endif
+ }
+ 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 = *p - '0';
+ p++;
+ if ((numBytes == 2) || !isdigit(UCHAR(*p)) /* INTL: digit */
+ || (UCHAR(*p) >= '8')) {
+ break;
+ }
+ count = 3;
+ result = (result << 3) + (*p - '0');
+ p++;
+ if ((numBytes == 3) || !isdigit(UCHAR(*p)) /* INTL: digit */
+ || (UCHAR(*p) >= '8') || (result >= 0x20)) {
+ break;
+ }
+ count = 4;
+ result = UCHAR((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 (TclUCS4Complete(p, numBytes - 1)) {
+ count = TclUtfToUCS4(p, &result) + 1; /* +1 for '\' */
+ } else {
+ char utfBytes[8];
+
+ memcpy(utfBytes, p, numBytes - 1);
+ utfBytes[numBytes - 1] = '\0';
+ count = TclUtfToUCS4(utfBytes, &result) + 1;
+ }
+ break;
+ }
+
+ done:
+ if (readPtr != NULL) {
+ *readPtr = count;
+ }
+#if TCL_UTF_MAX < 4
+ if (result > 0xFFFF) {
+ result = 0xFFFD;
+ }
+#endif
+ return TclUCS4ToUtf(result, dst);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseComment --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseComment(
+ const char *src, /* First character to parse. */
+ int numBytes, /* Max number of bytes to scan. */
+ Tcl_Parse *parsePtr) /* Information about parse in progress.
+ * Updated if parsing indicates an incomplete
+ * command. */
+{
+ const char *p = src;
+
+ while (numBytes) {
+ char type;
+ int scanned;
+
+ do {
+ scanned = ParseWhiteSpace(p, numBytes,
+ &parsePtr->incomplete, &type);
+ 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 = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete,
+ &type);
+ if (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.
+ */
+
+ TclParseBackslash(p, numBytes, &scanned, NULL);
+ p += scanned;
+ numBytes -= scanned;
+ }
+ } else {
+ p++;
+ numBytes--;
+ if (p[-1] == '\n') {
+ break;
+ }
+ }
+ }
+ parsePtr->commentSize = p - parsePtr->commentStart;
+ }
+ return (p - src);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * ParseTokens --
+ *
+ * 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 is
+ * not NULL, then an error message is left in the interpreter's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ParseTokens(
+ const char *src, /* First character to parse. */
+ int numBytes, /* Max number of bytes to scan. */
+ 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 flags, /* OR-ed bits indicating what substitutions to
+ * perform: TCL_SUBST_COMMANDS,
+ * TCL_SUBST_VARIABLES, and
+ * TCL_SUBST_BACKSLASHES */
+ Tcl_Parse *parsePtr) /* Information about parse in progress.
+ * Updated with additional tokens and
+ * termination information. */
+{
+ char type;
+ int originalTokens;
+ int noSubstCmds = !(flags & TCL_SUBST_COMMANDS);
+ int noSubstVars = !(flags & TCL_SUBST_VARIABLES);
+ int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES);
+ Tcl_Token *tokenPtr;
+
+ /*
+ * 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;
+ while (numBytes && !((type = CHAR_TYPE(*src)) & mask)) {
+ TclGrowParseTokenArray(parsePtr, 1);
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ if ((type & TYPE_SUBS) == 0) {
+ /*
+ * This is a simple range of characters. Scan to find the end of
+ * the range.
+ */
+
+ while ((++src, --numBytes)
+ && !(CHAR_TYPE(*src) & (mask | TYPE_SUBS))) {
+ /* empty loop */
+ }
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = src - tokenPtr->start;
+ parsePtr->numTokens++;
+ } else if (*src == '$') {
+ int varToken;
+
+ if (noSubstVars) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++;
+ numBytes--;
+ continue;
+ }
+
+ /*
+ * This is a variable reference. Call Tcl_ParseVarName to do all
+ * the dirty work of parsing the name.
+ */
+
+ varToken = parsePtr->numTokens;
+ if (Tcl_ParseVarName(parsePtr->interp, src, numBytes, parsePtr,
+ 1) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ src += parsePtr->tokenPtr[varToken].size;
+ numBytes -= parsePtr->tokenPtr[varToken].size;
+ } else if (*src == '[') {
+ Tcl_Parse *nestedPtr;
+
+ if (noSubstCmds) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++;
+ numBytes--;
+ continue;
+ }
+
+ /*
+ * Command substitution. Call Tcl_ParseCommand recursively (and
+ * repeatedly) to parse the nested command(s), then throw away the
+ * parse information.
+ */
+
+ src++;
+ numBytes--;
+ nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
+ while (1) {
+ const char *curEnd;
+
+ if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
+ nestedPtr) != TCL_OK) {
+ parsePtr->errorType = nestedPtr->errorType;
+ parsePtr->term = nestedPtr->term;
+ parsePtr->incomplete = nestedPtr->incomplete;
+ TclStackFree(parsePtr->interp, nestedPtr);
+ return TCL_ERROR;
+ }
+ curEnd = src + numBytes;
+ src = nestedPtr->commandStart + nestedPtr->commandSize;
+ numBytes = curEnd - src;
+ Tcl_FreeParse(nestedPtr);
+
+ /*
+ * Check for the closing ']' that ends the command
+ * substitution. It must have been the last character of the
+ * parsed command.
+ */
+
+ if ((nestedPtr->term < parsePtr->end)
+ && (*(nestedPtr->term) == ']')
+ && !(nestedPtr->incomplete)) {
+ break;
+ }
+ if (numBytes == 0) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-bracket", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
+ parsePtr->term = tokenPtr->start;
+ parsePtr->incomplete = 1;
+ TclStackFree(parsePtr->interp, nestedPtr);
+ return TCL_ERROR;
+ }
+ }
+ TclStackFree(parsePtr->interp, nestedPtr);
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->size = src - tokenPtr->start;
+ parsePtr->numTokens++;
+ } else if (*src == '\\') {
+ if (noSubstBS) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ src++;
+ numBytes--;
+ continue;
+ }
+
+ /*
+ * Backslash substitution.
+ */
+
+ TclParseBackslash(src, numBytes, &tokenPtr->size, NULL);
+
+ if (tokenPtr->size == 1) {
+ /*
+ * Just a backslash, due to end of string.
+ */
+
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ parsePtr->numTokens++;
+ src++;
+ numBytes--;
+ continue;
+ }
+
+ if (src[1] == '\n') {
+ if (numBytes == 2) {
+ parsePtr->incomplete = 1;
+ }
+
+ /*
+ * 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) {
+ if (parsePtr->numTokens == originalTokens) {
+ goto finishToken;
+ }
+ break;
+ }
+ }
+
+ tokenPtr->type = TCL_TOKEN_BS;
+ parsePtr->numTokens++;
+ src += tokenPtr->size;
+ numBytes -= tokenPtr->size;
+ } else if (*src == 0) {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ parsePtr->numTokens++;
+ 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.
+ */
+
+ TclGrowParseTokenArray(parsePtr, 1);
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ finishToken:
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 0;
+ parsePtr->numTokens++;
+ }
+ parsePtr->term = src;
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FreeParse --
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_FreeParse(
+ Tcl_Parse *parsePtr) /* Structure that was filled in by a previous
+ * call to Tcl_ParseCommand. */
+{
+ if (parsePtr->tokenPtr != parsePtr->staticTokens) {
+ ckfree(parsePtr->tokenPtr);
+ parsePtr->tokenPtr = parsePtr->staticTokens;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * 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.
+ *
+ * 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 function
+ * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
+ * release any additional space that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseVarName(
+ 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 "$". */
+ 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. */
+ int append) /* Non-zero means append tokens to existing
+ * information in parsePtr; zero means ignore
+ * existing tokens in parsePtr and
+ * reinitialize it. */
+{
+ Tcl_Token *tokenPtr;
+ const char *src;
+ int varIndex;
+ unsigned array;
+
+ if (numBytes < 0 && start) {
+ numBytes = strlen(start);
+ }
+ if (!append) {
+ TclParseInit(interp, start, numBytes, parsePtr);
+ }
+ if ((numBytes == 0) || (start == NULL)) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * 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;
+ TclGrowParseTokenArray(parsePtr, 2);
+ tokenPtr = &parsePtr->tokenPtr[parsePtr->numTokens];
+ tokenPtr->type = TCL_TOKEN_VARIABLE;
+ tokenPtr->start = src;
+ varIndex = parsePtr->numTokens;
+ parsePtr->numTokens++;
+ tokenPtr++;
+ src++;
+ numBytes--;
+ if (numBytes == 0) {
+ goto justADollarSign;
+ }
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ /*
+ * 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 "$".
+ */
+
+ if (*src == '{') {
+ src++;
+ numBytes--;
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ while (numBytes && (*src != '}')) {
+ numBytes--;
+ src++;
+ }
+ if (numBytes == 0) {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace for variable name", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_MISSING_VAR_BRACE;
+ parsePtr->term = tokenPtr->start-1;
+ parsePtr->incomplete = 1;
+ goto error;
+ }
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr[-1].size = src - tokenPtr[-1].start;
+ parsePtr->numTokens++;
+ src++;
+ } else {
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src;
+ tokenPtr->numComponents = 0;
+
+ while (numBytes) {
+ if (TclIsBareword(*src)) {
+ src += 1;
+ numBytes -= 1;
+ continue;
+ }
+ if ((src[0] == ':') && (numBytes != 1) && (src[1] == ':')) {
+ src += 2;
+ numBytes -= 2;
+ while (numBytes && (*src == ':')) {
+ src++;
+ numBytes--;
+ }
+ continue;
+ }
+ break;
+ }
+
+ /*
+ * Support for empty array names here.
+ */
+
+ array = (numBytes && (*src == '('));
+ tokenPtr->size = src - tokenPtr->start;
+ if ((tokenPtr->size == 0) && !array) {
+ goto justADollarSign;
+ }
+ 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.
+ */
+
+ 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->interp != NULL) {
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing )", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
+ parsePtr->term = src;
+ parsePtr->incomplete = 1;
+ goto error;
+ }
+ src = parsePtr->term + 1;
+ }
+ }
+ tokenPtr = &parsePtr->tokenPtr[varIndex];
+ tokenPtr->size = src - tokenPtr->start;
+ tokenPtr->numComponents = parsePtr->numTokens - (varIndex + 1);
+ 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.
+ */
+
+ justADollarSign:
+ tokenPtr = &parsePtr->tokenPtr[varIndex];
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->size = 1;
+ tokenPtr->numComponents = 0;
+ return TCL_OK;
+
+ error:
+ Tcl_FreeParse(parsePtr);
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseVar --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+const char *
+Tcl_ParseVar(
+ Tcl_Interp *interp, /* Context for looking up variable. */
+ const char *start, /* Start of variable substitution. First
+ * character must be "$". */
+ const char **termPtr) /* If non-NULL, points to word to fill in with
+ * character just after last one in the
+ * variable specifier. */
+{
+ Tcl_Obj *objPtr;
+ int code;
+ Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+
+ if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
+ TclStackFree(interp, parsePtr);
+ return NULL;
+ }
+
+ if (termPtr != NULL) {
+ *termPtr = start + parsePtr->tokenPtr->size;
+ }
+ if (parsePtr->numTokens == 1) {
+ /*
+ * There isn't a variable name after all: the $ is just a $.
+ */
+
+ TclStackFree(interp, parsePtr);
+ return "$";
+ }
+
+ code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
+ NULL, 1, NULL, NULL);
+ Tcl_FreeParse(parsePtr);
+ TclStackFree(interp, parsePtr);
+ if (code != TCL_OK) {
+ return NULL;
+ }
+ 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.
+ *
+ * Since TclSubstTokens above returned TCL_OK, we know that objPtr
+ * is shared. It is in both the interp result and the value of the
+ * variable. Returning the string relies on that to be true.
+ */
+
+ assert( Tcl_IsShared(objPtr) );
+
+ Tcl_ResetResult(interp);
+ return TclGetString(objPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseBraces --
+ *
+ * Given a string in braces such as a Tcl command argument or a string
+ * 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.
+ *
+ * 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 function
+ * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
+ * release any additional space that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseBraces(
+ 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 {'. */
+ 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 string. */
+ int append, /* Non-zero means append tokens to existing
+ * 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. */
+{
+ Tcl_Token *tokenPtr;
+ const char *src;
+ int startIndex, level, length;
+
+ if (numBytes < 0 && start) {
+ numBytes = strlen(start);
+ }
+ if (!append) {
+ TclParseInit(interp, start, numBytes, parsePtr);
+ }
+ if ((numBytes == 0) || (start == NULL)) {
+ return TCL_ERROR;
+ }
+
+ src = start;
+ startIndex = parsePtr->numTokens;
+
+ TclGrowParseTokenArray(parsePtr, 1);
+ tokenPtr = &parsePtr->tokenPtr[startIndex];
+ tokenPtr->type = TCL_TOKEN_TEXT;
+ tokenPtr->start = src+1;
+ tokenPtr->numComponents = 0;
+ level = 1;
+ while (1) {
+ while (++src, --numBytes) {
+ if (CHAR_TYPE(*src) != TYPE_NORMAL) {
+ break;
+ }
+ }
+ if (numBytes == 0) {
+ goto missingBraceError;
+ }
+
+ switch (*src) {
+ case '{':
+ level++;
+ 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;
+ }
+ 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++;
+ }
+ TclGrowParseTokenArray(parsePtr, 2);
+ 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;
+ }
+ }
+
+ missingBraceError:
+ parsePtr->errorType = TCL_PARSE_MISSING_BRACE;
+ parsePtr->term = start;
+ parsePtr->incomplete = 1;
+ if (parsePtr->interp == NULL) {
+ /*
+ * Skip straight to the exit code since we have no interpreter to put
+ * error message in.
+ */
+
+ goto error;
+ }
+
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing close-brace", -1));
+
+ /*
+ * 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.
+ */
+
+ {
+ int openBrace = 0;
+
+ while (--src > start) {
+ switch (*src) {
+ case '{':
+ openBrace = 1;
+ break;
+ case '\n':
+ openBrace = 0;
+ break;
+ case '#' :
+ if (openBrace && TclIsSpaceProcM(src[-1])) {
+ Tcl_AppendToObj(Tcl_GetObjResult(parsePtr->interp),
+ ": possible unbalanced brace in comment", -1);
+ goto error;
+ }
+ break;
+ }
+ }
+ }
+
+ error:
+ Tcl_FreeParse(parsePtr);
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_ParseQuotedString --
+ *
+ * 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.
+ *
+ * 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 function
+ * returns TCL_OK then the caller must eventually invoke Tcl_FreeParse to
+ * release any additional space that was allocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_ParseQuotedString(
+ 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 '"'. */
+ 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 string. */
+ int append, /* Non-zero means append tokens to existing
+ * 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. */
+{
+ if (numBytes < 0 && start) {
+ numBytes = strlen(start);
+ }
+ if (!append) {
+ TclParseInit(interp, start, numBytes, parsePtr);
+ }
+ if ((numBytes == 0) || (start == NULL)) {
+ return TCL_ERROR;
+ }
+
+ if (TCL_OK != ParseTokens(start+1, numBytes-1, TYPE_QUOTE, TCL_SUBST_ALL,
+ parsePtr)) {
+ goto error;
+ }
+ if (*parsePtr->term != '"') {
+ if (parsePtr->interp != NULL) {
+ Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj(
+ "missing \"", -1));
+ }
+ parsePtr->errorType = TCL_PARSE_MISSING_QUOTE;
+ parsePtr->term = start;
+ parsePtr->incomplete = 1;
+ goto error;
+ }
+ if (termPtr != NULL) {
+ *termPtr = (parsePtr->term + 1);
+ }
+ return TCL_OK;
+
+ error:
+ Tcl_FreeParse(parsePtr);
+ return TCL_ERROR;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSubstParse --
+ *
+ * Token parser used by the [subst] command. Parses the string made up of
+ * 'numBytes' bytes starting at 'bytes'. Parsing is controlled by the
+ * flags argument to provide support for the -nobackslashes, -nocommands,
+ * and -novariables options, as represented by the flag values
+ * TCL_SUBST_BACKSLASHES, TCL_SUBST_COMMANDS, TCL_SUBST_VARIABLES.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The Tcl_Parse struct '*parsePtr' is filled with parse results.
+ * The caller is expected to eventually call Tcl_FreeParse() to properly
+ * cleanup the value written there.
+ *
+ * If a parse error occurs, the Tcl_InterpState value '*statePtr' is
+ * filled with the state created by that error. When *statePtr is written
+ * to, the caller is expected to make the required calls to either
+ * Tcl_RestoreInterpState() or Tcl_DiscardInterpState() to dispose of the
+ * value written there.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclSubstParse(
+ Tcl_Interp *interp,
+ const char *bytes,
+ int numBytes,
+ int flags,
+ Tcl_Parse *parsePtr,
+ Tcl_InterpState *statePtr)
+{
+ int length = numBytes;
+ const char *p = bytes;
+
+ TclParseInit(interp, p, length, parsePtr);
+
+ /*
+ * 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, parsePtr)) {
+ /*
+ * There was a parse error. Save the interpreter state for possible
+ * error reporting later.
+ */
+
+ *statePtr = Tcl_SaveInterpState(interp, TCL_ERROR);
+
+ /*
+ * 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.
+ */
+
+ do {
+ parsePtr->numTokens = 0;
+ parsePtr->tokensAvailable = NUM_STATIC_TOKENS;
+ parsePtr->end = parsePtr->term;
+ parsePtr->incomplete = 0;
+ parsePtr->errorType = TCL_PARSE_SUCCESS;
+ } while (TCL_OK !=
+ ParseTokens(p, parsePtr->end - p, 0, flags, parsePtr));
+
+ /*
+ * The good parse will have to be followed by {, (, or [.
+ */
+
+ switch (*(parsePtr->term)) {
+ 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 (*(parsePtr->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 =
+ parsePtr->tokenPtr + parsePtr->numTokens - 2;
+
+ if (varTokenPtr->type != TCL_TOKEN_VARIABLE) {
+ Tcl_Panic("TclSubstParse: programming error");
+ }
+ if (varTokenPtr[1].type != TCL_TOKEN_TEXT) {
+ Tcl_Panic("TclSubstParse: programming error");
+ }
+ parsePtr->numTokens -= 2;
+ }
+ break;
+ case '[':
+ /*
+ * Parse error occurred during parsing of a toplevel command
+ * substitution.
+ */
+
+ parsePtr->end = p + length;
+ p = parsePtr->term + 1;
+ length = parsePtr->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;
+ const char *lastTerm = parsePtr->term;
+ Tcl_Parse *nestedPtr =
+ TclStackAlloc(interp, sizeof(Tcl_Parse));
+
+ while (TCL_OK ==
+ Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) {
+ Tcl_FreeParse(nestedPtr);
+ p = nestedPtr->term + (nestedPtr->term < nestedPtr->end);
+ length = nestedPtr->end - p;
+ if ((length == 0) && (nestedPtr->term == nestedPtr->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 = nestedPtr->term;
+ }
+ TclStackFree(interp, nestedPtr);
+
+ if (lastTerm == parsePtr->term) {
+ /*
+ * Parse error in first command. No commands to subst, add
+ * no more tokens.
+ */
+ break;
+ }
+
+ /*
+ * Create a command substitution token for whatever commands
+ * got parsed.
+ */
+
+ TclGrowParseTokenArray(parsePtr, 1);
+ tokenPtr = &(parsePtr->tokenPtr[parsePtr->numTokens]);
+ tokenPtr->start = parsePtr->term;
+ tokenPtr->numComponents = 0;
+ tokenPtr->type = TCL_TOKEN_COMMAND;
+ tokenPtr->size = lastTerm - tokenPtr->start + 1;
+ parsePtr->numTokens++;
+ }
+ break;
+
+ default:
+ Tcl_Panic("bad parse in TclSubstParse: %c", p[length]);
+ }
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * 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.
+ *
+ * Side effects:
+ * Can be anything, depending on the types of substitution done.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclSubstTokens(
+ 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 */
+ int line, /* The line the script starts on. */
+ int *clNextOuter, /* Information about an outer context for */
+ const char *outerScript) /* continuation line data. This is set by
+ * EvalEx() to properly handle [...]-nested
+ * commands. The 'outerScript' refers to the
+ * most-outer script containing the embedded
+ * command, which is refered to by 'script'.
+ * The 'clNextOuter' refers to the current
+ * entry in the table of continuation lines in
+ * this "main script", and the character
+ * offsets are relative to the 'outerScript'
+ * as well.
+ *
+ * If outerScript == script, then this call is
+ * for words in the outer-most script or
+ * command. See Tcl_EvalEx and TclEvalObjEx
+ * for the places generating arguments for
+ * which this is true. */
+{
+ Tcl_Obj *result;
+ int code = TCL_OK;
+#define NUM_STATIC_POS 20
+ int isLiteral, maxNumCL, numCL, i, adjust;
+ int *clPosition = NULL;
+ Interp *iPtr = (Interp *) interp;
+ int inFile = iPtr->evalFlags & TCL_EVAL_FILE;
+
+ /*
+ * 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.
+ *
+ * Further optimization opportunities might be to check for the equivalent
+ * of Tcl_SetObjResult(interp, Tcl_GetObjResult(interp)) and omit them.
+ */
+
+ /*
+ * For the handling of continuation lines in literals we first check if
+ * this is actually a literal. For if not we can forego the additional
+ * processing. Otherwise we pre-allocate a small table to store the
+ * locations of all continuation lines we find in this literal, if any.
+ * The table is extended if needed.
+ */
+
+ numCL = 0;
+ maxNumCL = 0;
+ isLiteral = 1;
+ for (i=0 ; i < count; i++) {
+ if ((tokenPtr[i].type != TCL_TOKEN_TEXT)
+ && (tokenPtr[i].type != TCL_TOKEN_BS)) {
+ isLiteral = 0;
+ break;
+ }
+ }
+
+ if (isLiteral) {
+ maxNumCL = NUM_STATIC_POS;
+ clPosition = ckalloc(maxNumCL * sizeof(int));
+ }
+
+ adjust = 0;
+ result = NULL;
+ 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_BS:
+ appendByteLength = TclParseBackslash(tokenPtr->start,
+ tokenPtr->size, NULL, utfCharBytes);
+ append = utfCharBytes;
+
+ /*
+ * If the backslash sequence we found is in a literal, and
+ * represented a continuation line, we compute and store its
+ * location (as char offset to the beginning of the _result_
+ * script). We may have to extend the table of locations.
+ *
+ * Note that the continuation line information is relevant even if
+ * the word we are processing is not a literal, as it can affect
+ * nested commands. See the branch for TCL_TOKEN_COMMAND below,
+ * where the adjustment we are tracking here is taken into
+ * account. The good thing is that we do not need a table of
+ * everything, just the number of lines we have to add as
+ * correction.
+ */
+
+ if ((appendByteLength == 1) && (utfCharBytes[0] == ' ')
+ && (tokenPtr->start[1] == '\n')) {
+ if (isLiteral) {
+ int clPos;
+
+ if (result == 0) {
+ clPos = 0;
+ } else {
+ Tcl_GetStringFromObj(result, &clPos);
+ }
+
+ if (numCL >= maxNumCL) {
+ maxNumCL *= 2;
+ clPosition = ckrealloc(clPosition,
+ maxNumCL * sizeof(int));
+ }
+ clPosition[numCL] = clPos;
+ numCL++;
+ }
+ adjust++;
+ }
+ break;
+
+ case TCL_TOKEN_COMMAND: {
+ /* TIP #280: Transfer line information to nested command */
+ iPtr->numLevels++;
+ code = TclInterpReady(interp);
+ if (code == TCL_OK) {
+ /*
+ * Test cases: info-30.{6,8,9}
+ */
+
+ int theline;
+
+ TclAdvanceContinuations(&line, &clNextOuter,
+ tokenPtr->start - outerScript);
+ theline = line + adjust;
+ code = TclEvalEx(interp, tokenPtr->start+1, tokenPtr->size-2,
+ 0, theline, clNextOuter, outerScript);
+
+ TclAdvanceLines(&line, tokenPtr->start+1,
+ tokenPtr->start + tokenPtr->size - 1);
+
+ /*
+ * Restore flag reset by nested eval for future bracketed
+ * commands and their cmdframe setup
+ */
+
+ if (inFile) {
+ iPtr->evalFlags |= TCL_EVAL_FILE;
+ }
+ }
+ iPtr->numLevels--;
+ TclResetCancellation(interp, 0);
+ 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, line, NULL, NULL);
+ arrayIndex = Tcl_GetObjResult(interp);
+ Tcl_IncrRefCount(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;
+ }
+ }
+
+ 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);
+ }
+
+ 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.
+ */
+ continue;
+ }
+
+ if (result == NULL) {
+ /*
+ * 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);
+ }
+ Tcl_IncrRefCount(result);
+ } else {
+ /*
+ * Subsequent passes. Append to result.
+ */
+
+ if (Tcl_IsShared(result)) {
+ Tcl_DecrRefCount(result);
+ result = Tcl_DuplicateObj(result);
+ Tcl_IncrRefCount(result);
+ }
+ if (appendObj != NULL) {
+ Tcl_AppendObjToObj(result, appendObj);
+ } else {
+ Tcl_AppendToObj(result, append, appendByteLength);
+ }
+ }
+ }
+
+ if (code != TCL_ERROR) { /* Keep error message in result! */
+ if (result != NULL) {
+ Tcl_SetObjResult(interp, result);
+
+ /*
+ * If the code found continuation lines (which implies that this
+ * word is a literal), then we store the accumulated table of
+ * locations in the thread-global data structure for the bytecode
+ * compiler to find later, assuming that the literal is a script
+ * which will be compiled.
+ */
+
+ if (numCL) {
+ TclContinuationsEnter(result, numCL, clPosition);
+ }
+
+ /*
+ * Release the temp table we used to collect the locations of
+ * continuation lines, if any.
+ */
+
+ if (maxNumCL) {
+ ckfree(clPosition);
+ }
+ } else {
+ Tcl_ResetResult(interp);
+ }
+ }
+ if (tokensLeftPtr != NULL) {
+ *tokensLeftPtr = count;
+ }
+ if (result != NULL) {
+ Tcl_DecrRefCount(result);
+ }
+ return code;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CommandComplete --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline int
+CommandComplete(
+ const char *script, /* Script to check. */
+ int numBytes) /* Number of bytes in script. */
+{
+ Tcl_Parse parse;
+ const char *p, *end;
+ int result;
+
+ p = script;
+ end = p + numBytes;
+ while (Tcl_ParseCommand(NULL, p, end - p, 0, &parse) == TCL_OK) {
+ p = parse.commandStart + parse.commandSize;
+ if (p >= end) {
+ break;
+ }
+ Tcl_FreeParse(&parse);
+ }
+ if (parse.incomplete) {
+ result = 0;
+ } else {
+ result = 1;
+ }
+ Tcl_FreeParse(&parse);
+ return result;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_CommandComplete --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_CommandComplete(
+ const char *script) /* Script to check. */
+{
+ return CommandComplete(script, (int) strlen(script));
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjCommandComplete --
+ *
+ * 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.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjCommandComplete(
+ Tcl_Obj *objPtr) /* Points to object holding script to
+ * check. */
+{
+ int length;
+ const char *script = Tcl_GetStringFromObj(objPtr, &length);
+
+ return CommandComplete(script, length);
+}
+\f
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
OSDN Git Service
