Logo Search packages:      
Sourcecode: tcltk8.0-ja version File versions  Download package

tclParse.c

/* 
 * tclParse.c --
 *
 *    This file contains a collection of procedures that are used
 *    to parse Tcl commands or parts of commands (like quoted
 *    strings or nested sub-commands).
 *
 * Copyright (c) 1987-1993 The Regents of the University of California.
 * Copyright (c) 1994-1997 Sun Microsystems, Inc.
 *
 * 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.2 1998/09/14 18:40:01 stanton Exp $
 */

#include "tclInt.h"
#include "tclPort.h"

/*
 * Function prototypes for procedures local to this file:
 */

static char *     QuoteEnd _ANSI_ARGS_((char *string, char *lastChar,
                int term));
static char *     ScriptEnd _ANSI_ARGS_((char *p, char *lastChar,
                int nested));
static char *     VarNameEnd _ANSI_ARGS_((char *string,  char *lastChar));

/*
 *--------------------------------------------------------------
 *
 * TclParseQuotes --
 *
 *    This procedure parses a double-quoted string such as a
 *    quoted Tcl command argument or a quoted value in a Tcl
 *    expression.  This procedure is also used to parse array
 *    element names within parentheses, or anything else that
 *    needs all the substitutions that happen in quotes.
 *
 * Results:
 *    The return value is a standard Tcl result, which is
 *    TCL_OK unless there was an error while parsing the
 *    quoted string.  If an error occurs then interp->result
 *    contains a standard error message.  *TermPtr is filled
 *    in with the address of the character just after the
 *    last one successfully processed;  this is usually the
 *    character just after the matching close-quote.  The
 *    fully-substituted contents of the quotes are stored in
 *    standard fashion in *pvPtr, null-terminated with
 *    pvPtr->next pointing to the terminating null character.
 *
 * Side effects:
 *    The buffer space in pvPtr may be enlarged by calling its
 *    expandProc.
 *
 *--------------------------------------------------------------
 */

int
TclParseQuotes(interp, string, termChar, flags, termPtr, pvPtr)
    Tcl_Interp *interp;       /* Interpreter to use for nested command
                         * evaluations and error messages. */
    char *string;       /* Character just after opening double-
                         * quote. */
    int termChar;       /* Character that terminates "quoted" string
                         * (usually double-quote, but sometimes
                         * right-paren or something else). */
    int flags;                /* Flags to pass to nested Tcl_Eval calls. */
    char **termPtr;           /* Store address of terminating character
                         * here. */
    ParseValue *pvPtr;        /* Information about where to place
                         * fully-substituted result of parse. */
{
    register char *src, *dst, c;
    char *lastChar = string + strlen(string);
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    src = string;
    dst = pvPtr->next;

    while (1) {
      if (dst == pvPtr->end) {
          /*
           * Target buffer space is about to run out.  Make more space.
           */

          pvPtr->next = dst;
          (*pvPtr->expandProc)(pvPtr, 1);
          dst = pvPtr->next;
      }

      c = *src;
      src++;
#ifdef KANJI
      if (IS_KANJISTART(UCHAR(*(src-1)))) {
          Tcl_KanjiSkip(src-1, lastChar, &kanjiCode);
          pvPtr->next = dst;
          (void)TclParseKanji(interp, src-1, lastChar, kanjiCode, termPtr, pvPtr);
          src = *termPtr;
          dst = pvPtr->next;
      } else
#endif /* KANJI */
      if (c == termChar) {
          *dst = '\0';
          pvPtr->next = dst;
          *termPtr = src;
          return TCL_OK;
      } else if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
          copy:
          *dst = c;
          dst++;
          continue;
      } else if (c == '$') {
          int length;
          char *value;

          value = Tcl_ParseVar(interp, src-1, termPtr);
          if (value == NULL) {
            return TCL_ERROR;
          }
          src = *termPtr;
          length = strlen(value);
          if ((pvPtr->end - dst) <= length) {
            pvPtr->next = dst;
            (*pvPtr->expandProc)(pvPtr, length);
            dst = pvPtr->next;
          }
          strcpy(dst, value);
          dst += length;
          continue;
      } else if (c == '[') {
          int result;

          pvPtr->next = dst;
          result = TclParseNestedCmd(interp, src, flags, termPtr, pvPtr);
          if (result != TCL_OK) {
            return result;
          }
          src = *termPtr;
          dst = pvPtr->next;
          continue;
      } else if (c == '\\') {
          int numRead;

          src--;
          *dst = Tcl_Backslash(src, &numRead);
          dst++;
          src += numRead;
          continue;
      } else if (c == '\0') {
          char buf[30];
          
          Tcl_ResetResult(interp);
          sprintf(buf, "missing %c", termChar);
          Tcl_SetResult(interp, buf, TCL_VOLATILE);
          *termPtr = string-1;
          return TCL_ERROR;
      } else {
          goto copy;
      }
    }
}

/*
 *--------------------------------------------------------------
 *
 * TclParseNestedCmd --
 *
 *    This procedure parses a nested Tcl command between
 *    brackets, returning the result of the command.
 *
 * Results:
 *    The return value is a standard Tcl result, which is
 *    TCL_OK unless there was an error while executing the
 *    nested command.  If an error occurs then interp->result
 *    contains a standard error message.  *TermPtr is filled
 *    in with the address of the character just after the
 *    last one processed;  this is usually the character just
 *    after the matching close-bracket, or the null character
 *    at the end of the string if the close-bracket was missing
 *    (a missing close bracket is an error).  The result returned
 *    by the command is stored in standard fashion in *pvPtr,
 *    null-terminated, with pvPtr->next pointing to the null
 *    character.
 *
 * Side effects:
 *    The storage space at *pvPtr may be expanded.
 *
 *--------------------------------------------------------------
 */

int
TclParseNestedCmd(interp, string, flags, termPtr, pvPtr)
    Tcl_Interp *interp;       /* Interpreter to use for nested command
                         * evaluations and error messages. */
    char *string;       /* Character just after opening bracket. */
    int flags;                /* Flags to pass to nested Tcl_Eval. */
    char **termPtr;           /* Store address of terminating character
                         * here. */
    register ParseValue *pvPtr;     /* Information about where to place
                         * result of command. */
{
    int result, length, shortfall;
    Interp *iPtr = (Interp *) interp;

    iPtr->evalFlags = flags | TCL_BRACKET_TERM;
    result = Tcl_Eval(interp, string);
    *termPtr = (string + iPtr->termOffset);
    if (result != TCL_OK) {
      /*
       * The increment below results in slightly cleaner message in
       * the errorInfo variable (the close-bracket will appear).
       */

      if (**termPtr == ']') {
          *termPtr += 1;
      }
      return result;
    }
    (*termPtr) += 1;
    length = strlen(iPtr->result);
    shortfall = length + 1 - (pvPtr->end - pvPtr->next);
    if (shortfall > 0) {
      (*pvPtr->expandProc)(pvPtr, shortfall);
    }
    strcpy(pvPtr->next, iPtr->result);
    pvPtr->next += length;
    
    Tcl_FreeResult(interp);
    iPtr->result = iPtr->resultSpace;
    iPtr->resultSpace[0] = '\0';
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * TclParseBraces --
 *
 *    This procedure scans the information between matching
 *    curly braces.
 *
 * Results:
 *    The return value is a standard Tcl result, which is
 *    TCL_OK unless there was an error while parsing string.
 *    If an error occurs then interp->result contains a
 *    standard error message.  *TermPtr is filled
 *    in with the address of the character just after the
 *    last one successfully processed;  this is usually the
 *    character just after the matching close-brace.  The
 *    information between curly braces is stored in standard
 *    fashion in *pvPtr, null-terminated with pvPtr->next
 *    pointing to the terminating null character.
 *
 * Side effects:
 *    The storage space at *pvPtr may be expanded.
 *
 *--------------------------------------------------------------
 */

int
TclParseBraces(interp, string, termPtr, pvPtr)
    Tcl_Interp *interp;       /* Interpreter to use for nested command
                         * evaluations and error messages. */
    char *string;       /* Character just after opening bracket. */
    char **termPtr;           /* Store address of terminating character
                         * here. */
    register ParseValue *pvPtr;     /* Information about where to place
                         * result of command. */
{
    int level;
    register char *src, *dst, *end;
    register char c;
    char *lastChar = string + strlen(string);
#ifdef KANJI
    int kanjiCode = TCL_ANY;
#endif /* KANJI */

    src = string;
    dst = pvPtr->next;
    end = pvPtr->end;
    level = 1;

    /*
     * Copy the characters one at a time to the result area, stopping
     * when the matching close-brace is found.
     */

    while (1) {
#ifdef KANJI
      if (IS_KANJISTART(UCHAR(*src))) {
          Tcl_KanjiSkip(src, lastChar, &kanjiCode);
          pvPtr->next = dst;
          (void)TclParseKanji(interp, src, lastChar, kanjiCode, termPtr, pvPtr);
          src = *termPtr;
          dst = pvPtr->next;
          end = pvPtr->end;
      }
#endif /* KANJI */
      c = *src;
      src++;
      if (dst == end) {
          pvPtr->next = dst;
          (*pvPtr->expandProc)(pvPtr, 20);
          dst = pvPtr->next;
          end = pvPtr->end;
      }
      *dst = c;
      dst++;
      if (CHAR_TYPE(src-1, lastChar) == TCL_NORMAL) {
          continue;
      } else if (c == '{') {
          level++;
      } else if (c == '}') {
          level--;
          if (level == 0) {
            dst--;                  /* Don't copy the last close brace. */
            break;
          }
      } else if (c == '\\') {
          int count;

          /*
           * Must always squish out backslash-newlines, even when in
           * braces.  This is needed so that this sequence can appear
           * anywhere in a command, such as the middle of an expression.
           */

          if (*src == '\n') {
            dst[-1] = Tcl_Backslash(src-1, &count);
            src += count - 1;
          } else {
            (void) Tcl_Backslash(src-1, &count);
            while (count > 1) {
                    if (dst == end) {
                        pvPtr->next = dst;
                        (*pvPtr->expandProc)(pvPtr, 20);
                        dst = pvPtr->next;
                        end = pvPtr->end;
                    }
                *dst = *src;
                dst++;
                src++;
                count--;
            }
          }
      } else if (c == '\0') {
          Tcl_SetResult(interp, "missing close-brace", TCL_STATIC);
          *termPtr = string-1;
          return TCL_ERROR;
      }
    }

    *dst = '\0';
    pvPtr->next = dst;
    *termPtr = src;
    return TCL_OK;
}

/*
 *--------------------------------------------------------------
 *
 * TclExpandParseValue --
 *
 *    This procedure is commonly used as the value of the
 *    expandProc in a ParseValue.  It uses malloc to allocate
 *    more space for the result of a parse.
 *
 * Results:
 *    The buffer space in *pvPtr is reallocated to something
 *    larger, and if pvPtr->clientData is non-zero the old
 *    buffer is freed.  Information is copied from the old
 *    buffer to the new one.
 *
 * Side effects:
 *    None.
 *
 *--------------------------------------------------------------
 */

void
TclExpandParseValue(pvPtr, needed)
    register ParseValue *pvPtr;           /* Information about buffer that
                               * must be expanded.  If the clientData
                               * in the structure is non-zero, it
                               * means that the current buffer is
                               * dynamically allocated. */
    int needed;                     /* Minimum amount of additional space
                               * to allocate. */
{
    int newSpace;
    char *new;

    /*
     * Either double the size of the buffer or add enough new space
     * to meet the demand, whichever produces a larger new buffer.
     */

    newSpace = (pvPtr->end - pvPtr->buffer) + 1;
    if (newSpace < needed) {
      newSpace += needed;
    } else {
      newSpace += newSpace;
    }
    new = (char *) ckalloc((unsigned) newSpace);

    /*
     * Copy from old buffer to new, free old buffer if needed, and
     * mark new buffer as malloc-ed.
     */

    memcpy((VOID *) new, (VOID *) pvPtr->buffer,
          (size_t) (pvPtr->next - pvPtr->buffer));
    pvPtr->next = new + (pvPtr->next - pvPtr->buffer);
    if (pvPtr->clientData != 0) {
      ckfree(pvPtr->buffer);
    }
    pvPtr->buffer = new;
    pvPtr->end = new + newSpace - 1;
    pvPtr->clientData = (ClientData) 1;
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordEnd --
 *
 *    Given a pointer into a Tcl command, find the end of the next
 *    word of the command.
 *
 * Results:
 *    The return value is a pointer to the last character that's part
 *    of the word pointed to by "start".  If the word doesn't end
 *    properly within the string then the return value is the address
 *    of the null character at the end of the string.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

char *
TclWordEnd(start, lastChar, nested, semiPtr)
    char *start;        /* Beginning of a word of a Tcl command. */
    char *lastChar;           /* Terminating character in string. */
    int nested;               /* Zero means this is a top-level command.
                         * One means this is a nested command (close
                         * bracket is a word terminator). */
    int *semiPtr;       /* Set to 1 if word ends with a command-
                         * terminating semi-colon, zero otherwise.
                         * If NULL then ignored. */
{
    register char *p;
    int count;

    if (semiPtr != NULL) {
      *semiPtr = 0;
    }

    /*
     * Skip leading white space (backslash-newline must be treated like
     * white-space, except that it better not be the last thing in the
     * command).
     */

    for (p = start; ; p++) {
      if (isspace(UCHAR(*p))) {
          continue;
      }
      if ((p[0] == '\\') && (p[1] == '\n')) {
          if (p+2 == lastChar) {
            return p+2;
          }
          continue;
      }
      break;
    }

    /*
     * Handle words beginning with a double-quote or a brace.
     */

    if (*p == '"') {
      p = QuoteEnd(p+1, lastChar, '"');
      if (p == lastChar) {
          return p;
      }
      p++;
    } else if (*p == '{') {
      int braces = 1;
#ifdef KANJI
      p++;
      while (braces != 0) {
          if (IS_KANJISTART(UCHAR(*p))) {
            p += Tcl_KanjiSkip(p, lastChar, NULL);
            continue;
          } else if (*p == '\\') {
            (void) Tcl_Backslash(p, &count);
            p += count;
            continue;
          }
          if (*p == '}') {
            braces--;
          } else if (*p == '{') {
            braces++;
          } else if (p == lastChar) {
            return p;
          }
          p++;
      }
#else
      while (braces != 0) {
          p++;
          while (*p == '\\') {
            (void) Tcl_Backslash(p, &count);
            p += count;
          }
          if (*p == '}') {
            braces--;
          } else if (*p == '{') {
            braces++;
          } else if (p == lastChar) {
            return p;
          }
      }
      p++;
#endif /* KANJI */
    }

    /*
     * Handle words that don't start with a brace or double-quote.
     * This code is also invoked if the word starts with a brace or
     * double-quote and there is garbage after the closing brace or
     * quote.  This is an error as far as Tcl_Eval is concerned, but
     * for here the garbage is treated as part of the word.
     */

    while (1) {
#ifdef KANJI
      if (IS_KANJISTART(UCHAR(*p))) {
          p += Tcl_KanjiSkip(p, lastChar, NULL);
      } else
#endif /* KANJI */
      if (*p == '[') {
          p = ScriptEnd(p+1, lastChar, 1);
          if (p == lastChar) {
            return p;
          }
          p++;
      } else if (*p == '\\') {
          if (p[1] == '\n') {
            /*
             * Backslash-newline:  it maps to a space character
             * that is a word separator, so the word ends just before
             * the backslash.
             */

            return p-1;
          }
          (void) Tcl_Backslash(p, &count);
          p += count;
      } else if (*p == '$') {
          p = VarNameEnd(p, lastChar);
          if (p == lastChar) {
            return p;
          }
          p++;
      } else if (*p == ';') {
          /*
           * Include the semi-colon in the word that is returned.
           */

          if (semiPtr != NULL) {
            *semiPtr = 1;
          }
          return p;
      } else if (isspace(UCHAR(*p))) {
          return p-1;
      } else if ((*p == ']') && nested) {
          return p-1;
      } else if (p == lastChar) {
          if (nested) {
            /*
             * Nested commands can't end because of the end of the
             * string.
             */
            return p;
          }
          return p-1;
      } else {
          p++;
      }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * QuoteEnd --
 *
 *    Given a pointer to a string that obeys the parsing conventions
 *    for quoted things in Tcl, find the end of that quoted thing.
 *    The actual thing may be a quoted argument or a parenthesized
 *    index name.
 *
 * Results:
 *    The return value is a pointer to the last character that is
 *    part of the quoted string (i.e the character that's equal to
 *    term).  If the quoted string doesn't terminate properly then
 *    the return value is a pointer to the null character at the
 *    end of the string.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static char *
QuoteEnd(string, lastChar, term)
    char *string;       /* Pointer to character just after opening
                         * "quote". */
    char *lastChar;           /* Terminating character in string. */
    int term;                 /* This character will terminate the
                         * quoted string (e.g. '"' or ')'). */
{
    register char *p = string;
    int count;

    while (*p != term) {
#ifdef KANJI
      if (IS_KANJISTART(UCHAR(*p))) {
          p += Tcl_KanjiSkip(p, lastChar, NULL);
      } else
#endif /* KANJI */
      if (*p == '\\') {
          (void) Tcl_Backslash(p, &count);
          p += count;
      } else if (*p == '[') {
          for (p++; *p != ']'; p++) {
            p = TclWordEnd(p, lastChar, 1, (int *) NULL);
            if (*p == 0) {
                return p;
            }
          }
          p++;
      } else if (*p == '$') {
          p = VarNameEnd(p, lastChar);
          if (*p == 0) {
            return p;
          }
          p++;
      } else if (p == lastChar) {
          return p;
      } else {
          p++;
      }
    }
    return p-1;
}

/*
 *----------------------------------------------------------------------
 *
 * VarNameEnd --
 *
 *    Given a pointer to a variable reference using $-notation, find
 *    the end of the variable name spec.
 *
 * Results:
 *    The return value is a pointer to the last character that
 *    is part of the variable name.  If the variable name doesn't
 *    terminate properly then the return value is a pointer to the
 *    null character at the end of the string.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static char *
VarNameEnd(string, lastChar)
    char *string;       /* Pointer to dollar-sign character. */
    char *lastChar;           /* Terminating character in string. */
{
    register char *p = string+1;

    if (*p == '{') {
      for (p++; (*p != '}') && (p != lastChar); p++) {
#ifdef KANJI
          if (IS_KANJISTART(UCHAR(*p))) {
            p += (Tcl_KanjiSkip(p, lastChar, NULL) - 1);
            continue;
          }
#else
          /* Empty loop body. */
#endif /* KANJI */
      }
      return p;
    }
#ifdef KANJI
    while (isalnum(UCHAR(*p)) || (*p == '_') ||
         IS_KANJISTART(UCHAR(*p))) {
      if (IS_KANJISTART(UCHAR(*p))) {
          p += Tcl_KanjiSkip(p, lastChar, NULL);
      } else {
          p++;
      }
    }
#else
    while (isalnum(UCHAR(*p)) || (*p == '_')) {
      p++;
    }
#endif
    if ((*p == '(') && (p != string+1)) {
      return QuoteEnd(p+1, lastChar, ')');
    }
    return p-1;
}


/*
 *----------------------------------------------------------------------
 *
 * ScriptEnd --
 *
 *    Given a pointer to the beginning of a Tcl script, find the end of
 *    the script.
 *
 * Results:
 *    The return value is a pointer to the last character that's part
 *    of the script pointed to by "p".  If the command doesn't end
 *    properly within the string then the return value is the address
 *    of the null character at the end of the string.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

static char *
ScriptEnd(p, lastChar, nested)
    char *p;                  /* Script to check. */
    char *lastChar;           /* Terminating character in string. */
    int nested;               /* Zero means this is a top-level command.
                         * One means this is a nested command (the
                         * last character of the script must be
                         * an unquoted ]). */
{
    int commentOK = 1;
    int length;

    while (1) {
      while (isspace(UCHAR(*p))) {
          if (*p == '\n') {
            commentOK = 1;
          }
          p++;
      }
      if ((*p == '#') && commentOK) {
          do {
            if (*p == '\\') {
                /*
                 * If the script ends with backslash-newline, then
                 * this command isn't complete.
                 */

                if ((p[1] == '\n') && (p+2 == lastChar)) {
                  return p+2;
                }
                Tcl_Backslash(p, &length);
                p += length;
            } else {
                p++;
            }
          } while ((p != lastChar) && (*p != '\n'));
          continue;
      }
      p = TclWordEnd(p, lastChar, nested, &commentOK);
      if (p == lastChar) {
          return p;
      }
      p++;
      if (nested) {
          if (*p == ']') {
            return p;
          }
      } else {
          if (p == lastChar) {
            return p-1;
          }
      }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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->result.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_ParseVar(interp, string, termPtr)
    Tcl_Interp *interp;             /* Context for looking up variable. */
    register char *string;          /* String containing variable name.
                               * First character must be "$". */
    char **termPtr;                 /* If non-NULL, points to word to fill
                               * in with character just after last
                               * one in the variable specifier. */

{
    char *name1, *name1End, c, *result;
    register char *name2;
#define NUM_CHARS 200
    char copyStorage[NUM_CHARS];
    ParseValue pv;
#ifdef KANJI
    unsigned char *sEnd = string + strlen(string);
#endif /* KANJI */

    /*
     * There are three cases:
     * 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, or a "::" namespace separator.
     *    If the following character is an open parenthesis, then the
     *    information between parentheses is the array element name, which
     *    can include any of the substitutions permissible between quotes.
     * 3. The $ sign is followed by something that isn't a letter, digit,
     *    underscore, or a "::" namespace separator: in this case,
     *    there is no variable name, and "$" is returned.
     */

    name2 = NULL;
    string++;
    if (*string == '{') {
      string++;
      name1 = string;
      while (*string != '}') {
          if (*string == 0) {
            Tcl_SetResult(interp, "missing close-brace for variable name",
                  TCL_STATIC);
            if (termPtr != 0) {
                *termPtr = string;
            }
            return NULL;
          }
#ifdef KANJI
          if (IS_KANJISTART(UCHAR(*string))) {
            string += Tcl_KanjiSkip(string, sEnd, NULL);
            continue;
          }
#endif /* KANJI */
          string++;
      }
      name1End = string;
      string++;
    } else {
      name1 = string;
#ifdef KANJI
      while (isalnum(UCHAR(*string)) || (*string == '_')
              || (*string == ':') || IS_KANJISTART(UCHAR(*string))) {
          if (IS_KANJISTART(UCHAR(*string))) {
                string += Tcl_KanjiSkip(string, sEnd, NULL);
                continue;
            }
#else
      while (isalnum(UCHAR(*string)) || (*string == '_')
              || (*string == ':')) {
#endif /* KANJI */
          if (*string == ':') {
            if (*(string+1) == ':') {
                    string += 2;  /* skip over the initial :: */
                while (*string == ':') {
                  string++; /* skip over a subsequent : */
                }
            } else {
                break;    /* : by itself */
                }
          } else {
            string++;
          }
      }
      if (string == name1) {
          if (termPtr != 0) {
            *termPtr = string;
          }
          return "$";
      }
      name1End = string;
      if (*string == '(') {
          char *end;

          /*
           * Perform substitutions on the array element name, just as
           * is done for quotes.
           */

          pv.buffer = pv.next = copyStorage;
          pv.end = copyStorage + NUM_CHARS - 1;
          pv.expandProc = TclExpandParseValue;
          pv.clientData = (ClientData) NULL;
          if (TclParseQuotes(interp, string+1, ')', 0, &end, &pv)
                != TCL_OK) {
            char msg[200];
            int length;

            length = string-name1;
            if (length > 100) {
                length = 100;
            }
            sprintf(msg, "\n    (parsing index for array \"%.*s\")",
                  length, name1);
            Tcl_AddErrorInfo(interp, msg);
            result = NULL;
            name2 = pv.buffer;
            if (termPtr != 0) {
                *termPtr = end;
            }
            goto done;
          }
          Tcl_ResetResult(interp);
          string = end;
          name2 = pv.buffer;
      }
    }
    if (termPtr != 0) {
      *termPtr = string;
    }

    c = *name1End;
    *name1End = 0;
    result = Tcl_GetVar2(interp, name1, name2, TCL_LEAVE_ERR_MSG);
    *name1End = c;

    done:
    if ((name2 != NULL) && (pv.buffer != copyStorage)) {
      ckfree(pv.buffer);
    }
    return result;
}

#ifdef KANJI
/*
 *----------------------------------------------------------------------
 *
 * TclParseKanji --
 *
 *    This procedure parses a kanji string which code is either
 *    JIS, SJIS,or EUC, and convert its code if necessary.
 *
 * Results:
 *    The return value is (currently) always TCL_OK.  If termPtr
 *    isn't NULL, *termPtr gets filled in with the address of the
 *    character just after the last one in the variable specifier.
 *    character just after the matching close-quote.  The fully-
 *    substituted contents of the kanji string are stored in 
 *    standard fashion in *pvPtr, null-terminated with pvPtr->next
 *    pointing to the terminating null character.
 *
 * Side effects:
 *    The buffer space in pvPtr may be enlarged by calling its
 *    expandProc.
 *
 *----------------------------------------------------------------------
 */

int
TclParseKanji(interp, string, end, kanjiCode, termPtr, pvPtr)
     Tcl_Interp *interp;
     char *string;
     char *end;
     int kanjiCode;
     char **termPtr;
     ParseValue *pvPtr;
{
    Interp *iPtr = (Interp *)interp;
    unsigned int length;

    length = Tcl_KanjiLength(string, end, kanjiCode);

    if( iPtr->kanjiCode == TCL_ANY || iPtr->kanjiCode == kanjiCode ) {

      if( (pvPtr->end - pvPtr->next) <= (int)length ) {
          (*pvPtr->expandProc)(pvPtr, (int)length);
      }

      strncpy(pvPtr->next, string, length);

      *termPtr = string + length;
      pvPtr->next += length;

    } else {
      char c;
      int n;
      wchar *ws;

      c = string[length];
      string[length] = '\0';

      n = Tcl_KanjiEncode(kanjiCode, string, NULL);
      ws = (wchar *)ckalloc((unsigned)((n + 1) * sizeof(wchar)));
      (void) Tcl_KanjiEncode(kanjiCode, string, ws);

      n = Tcl_KanjiDecode(iPtr->kanjiCode, ws, NULL);
      if( (pvPtr->end - pvPtr->next) <= (n+1) ) {
          (*pvPtr->expandProc)(pvPtr, (n+1));
      }
      (void) Tcl_KanjiDecode(iPtr->kanjiCode, ws, pvPtr->next);

      ckfree((char *) ws);
      string[length] = c;

      *termPtr = string + length;
      pvPtr->next += n;
    }

    return TCL_OK;
}
#endif /* KANJI */

/*
 *----------------------------------------------------------------------
 *
 * Tcl_CommandComplete --
 *
 *    Given a partial or complete Tcl command, this procedure
 *    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
Tcl_CommandComplete(cmd)
    char *cmd;                /* Command to check. */
{
    char *p;

    if (*cmd == 0) {
      return 1;
    }
    p = ScriptEnd(cmd, cmd+strlen(cmd), 0);
    return (*p != 0);
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Results:
 *    1 is returned if the command is complete, 0 otherwise.
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

int
TclObjCommandComplete(cmdPtr)
    Tcl_Obj *cmdPtr;                /* Points to object holding command
                               * to check. */
{
    char *cmd, *p;
    int length;

    cmd = Tcl_GetStringFromObj(cmdPtr, &length);
    if (length == 0) {
      return 1;
    }
    p = ScriptEnd(cmd, cmd+length, /*nested*/ 0);
    return (*p != 0);
}

Generated by  Doxygen 1.6.0   Back to index