Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/misc/volume25/tcl/part29

Text File | 1991-11-15 | 39.1 KB | 1,483 lines

Newsgroups: comp.sources.misc
From: [e-mail] (Karl Lehenbauer)
Subject:  v25i097:  tcl - tool command language, version 6.1, Part29/33
Message-ID: <[e-mail]>
X-Md4-Signature: 68b025872ee4e8c0dc5ec1b697e8a88e
Date: Fri, 15 Nov 1991 22:59:11 GMT
Approved: [e-mail]

Submitted-by: [e-mail] (Karl Lehenbauer)
Posting-number: Volume 25, Issue 97
Archive-name: tcl/part29
Environment: UNIX

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 29 (of 33)."
# Contents:  tcl6.1/tclUtil.c
# Wrapped by karl@one on Tue Nov 12 19:44:31 1991
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'tcl6.1/tclUtil.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'tcl6.1/tclUtil.c'\"
else
echo shar: Extracting \"'tcl6.1/tclUtil.c'\" \(36390 characters\)
sed "s/^X//" >'tcl6.1/tclUtil.c' <<'END_OF_FILE'
X/*
X * tclUtil.c --
X *
X *    This file contains utility procedures that are used by many Tcl
X *    commands.
X *
X * Copyright 1987-1991 Regents of the University of California
X * Permission to use, copy, modify, and distribute this
X * software and its documentation for any purpose and without
X * fee is hereby granted, provided that the above copyright
X * notice appear in all copies.  The University of California
X * makes no representations about the suitability of this
X * software for any purpose.  It is provided "as is" without
X * express or implied warranty.
X */
X
X#ifndef lint
Xstatic char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclUtil.c,v 1.60 91/10/17 15:49:56 ouster Exp $ SPRITE (Berkeley)";
X#endif
X
X#include "tclInt.h"
X
X/*
X * The following values are used in the flags returned by Tcl_ScanElement
X * and used by Tcl_ConvertElement.
X */
X
X#define USE_BRACES        1
X#define CANT_USE_BRACES        2
X
X/*
X * The variable below is set to NULL before invoking regexp functions
X * and checked after those functions.  If an error occurred then regerror
X * will set the variable to point to a (static) error message.  This
X * mechanism unfortunately does not support multi-threading, but then
X * neither does the rest of the regexp facilities.
X */
X
Xchar *tclRegexpError = NULL;
X
X/*
X * Function prototypes for local procedures in this file:
X */
X
Xstatic void        SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr,
X                int newSpace));
X
X/*
X *----------------------------------------------------------------------
X *
X * TclFindElement --
X *
X *    Given a pointer into a Tcl list, locate the first (or next)
X *    element in the list.
X *
X * Results:
X *    The return value is normally TCL_OK, which means that the
X *    element was successfully located.  If TCL_ERROR is returned
X *    it means that list didn't have proper list structure;
X *    interp->result contains a more detailed error message.
X *
X *    If TCL_OK is returned, then *elementPtr will be set to point
X *    to the first element of list, and *nextPtr will be set to point
X *    to the character just after any white space following the last
X *    character that's part of the element.  If this is the last argument
X *    in the list, then *nextPtr will point to the NULL character at the
X *    end of list.  If sizePtr is non-NULL, *sizePtr is filled in with
X *    the number of characters in the element.  If the element is in
X *    braces, then *elementPtr will point to the character after the
X *    opening brace and *sizePtr will not include either of the braces.
X *    If there isn't an element in the list, *sizePtr will be zero, and
X *    both *elementPtr and *termPtr will refer to the null character at
X *    the end of list.  Note:  this procedure does NOT collapse backslash
X *    sequences.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr)
X    Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
X    register char *list;    /* String containing Tcl list with zero
X                 * or more elements (possibly in braces). */
X    char **elementPtr;        /* Fill in with location of first significant
X                 * character in first element of list. */
X    char **nextPtr;        /* Fill in with location of character just
X                 * after all white space following end of
X                 * argument (i.e. next argument or end of
X                 * list). */
X    int *sizePtr;        /* If non-zero, fill in with size of
X                 * element. */
X    int *bracePtr;        /* If non-zero fill in with non-zero/zero
X                 * to indicate that arg was/wasn't
X                 * in braces. */
X{
X    register char *p;
X    int openBraces = 0;
X    int inQuotes = 0;
X    int size;
X
X    /*
X     * Skim off leading white space and check for an opening brace or
X     * quote.   Note:  use of "isascii" below and elsewhere in this
X     * procedure is a temporary hack (7/27/90) because Mx uses characters
X     * with the high-order bit set for some things.  This should probably
X     * be changed back eventually, or all of Tcl should call isascii.
X     */
X
X    while (isascii(*list) && isspace(*list)) {
X    list++;
X    }
X    if (*list == '{') {
X    openBraces = 1;
X    list++;
X    } else if (*list == '"') {
X    inQuotes = 1;
X    list++;
X    }
X    if (bracePtr != 0) {
X    *bracePtr = openBraces;
X    }
X    p = list;
X
X    /*
X     * Find the end of the element (either a space or a close brace or
X     * the end of the string).
X     */
X
X    while (1) {
X    switch (*p) {
X
X        /*
X         * Open brace: don't treat specially unless the element is
X         * in braces.  In this case, keep a nesting count.
X         */
X
X        case '{':
X        if (openBraces != 0) {
X            openBraces++;
X        }
X        break;
X
X        /*
X         * Close brace: if element is in braces, keep nesting
X         * count and quit when the last close brace is seen.
X         */
X
X        case '}':
X        if (openBraces == 1) {
X            char *p2;
X
X            size = p - list;
X            p++;
X            if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
X            goto done;
X            }
X            for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
X                p2++) {
X            /* null body */
X            }
X            Tcl_ResetResult(interp);
X            sprintf(interp->result,
X                "list element in braces followed by \"%.*s\" instead of space",
X                p2-p, p);
X            return TCL_ERROR;
X        } else if (openBraces != 0) {
X            openBraces--;
X        }
X        break;
X
X        /*
X         * Backslash:  skip over everything up to the end of the
X         * backslash sequence.
X         */
X
X        case '\\': {
X        int size;
X
X        (void) Tcl_Backslash(p, &size);
X        p += size - 1;
X        break;
X        }
X
X        /*
X         * Space: ignore if element is in braces or quotes;  otherwise
X         * terminate element.
X         */
X
X        case ' ':
X        case '\f':
X        case '\n':
X        case '\r':
X        case '\t':
X        case '\v':
X        if ((openBraces == 0) && !inQuotes) {
X            size = p - list;
X            goto done;
X        }
X        break;
X
X        /*
X         * Double-quote:  if element is in quotes then terminate it.
X         */
X
X        case '"':
X        if (inQuotes) {
X            char *p2;
X
X            size = p-list;
X            p++;
X            if ((isascii(*p) && isspace(*p)) || (*p == 0)) {
X            goto done;
X            }
X            for (p2 = p; (*p2 != 0) && (!isspace(*p2)) && (p2 < p+20);
X                p2++) {
X            /* null body */
X            }
X            Tcl_ResetResult(interp);
X            sprintf(interp->result,
X                "list element in quotes followed by \"%.*s\" %s",
X                p2-p, p, "instead of space");
X            return TCL_ERROR;
X        }
X        break;
X
X        /*
X         * End of list:  terminate element.
X         */
X
X        case 0:
X        if (openBraces != 0) {
X            Tcl_SetResult(interp, "unmatched open brace in list",
X                TCL_STATIC);
X            return TCL_ERROR;
X        } else if (inQuotes) {
X            Tcl_SetResult(interp, "unmatched open quote in list",
X                TCL_STATIC);
X            return TCL_ERROR;
X        }
X        size = p - list;
X        goto done;
X
X    }
X    p++;
X    }
X
X    done:
X    while (isascii(*p) && isspace(*p)) {
X    p++;
X    }
X    *elementPtr = list;
X    *nextPtr = p;
X    if (sizePtr != 0) {
X    *sizePtr = size;
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclCopyAndCollapse --
X *
X *    Copy a string and eliminate any backslashes that aren't in braces.
X *
X * Results:
X *    There is no return value.  Count chars. get copied from src
X *    to dst.  Along the way, if backslash sequences are found outside
X *    braces, the backslashes are eliminated in the copy.
X *    After scanning count chars. from source, a null character is
X *    placed at the end of dst.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTclCopyAndCollapse(count, src, dst)
X    int count;            /* Total number of characters to copy
X                 * from src. */
X    register char *src;        /* Copy from here... */
X    register char *dst;        /* ... to here. */
X{
X    register char c;
X    int numRead;
X
X    for (c = *src; count > 0; src++, c = *src, count--) {
X    if (c == '\\') {
X        *dst = Tcl_Backslash(src, &numRead);
X        if (*dst != 0) {
X        dst++;
X        }
X        src += numRead-1;
X        count -= numRead-1;
X    } else {
X        *dst = c;
X        dst++;
X    }
X    }
X    *dst = 0;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SplitList --
X *
X *    Splits a list up into its constituent fields.
X *
X * Results
X *    The return value is normally TCL_OK, which means that
X *    the list was successfully split up.  If TCL_ERROR is
X *    returned, it means that "list" didn't have proper list
X *    structure;  interp->result will contain a more detailed
X *    error message.
X *
X *    *argvPtr will be filled in with the address of an array
X *    whose elements point to the elements of list, in order.
X *    *argcPtr will get filled in with the number of valid elements
X *    in the array.  A single block of memory is dynamically allocated
X *    to hold both the argv array and a copy of the list (with
X *    backslashes and braces removed in the standard way).
X *    The caller must eventually free this memory by calling free()
X *    on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
X *    if the procedure returns normally.
X *
X * Side effects:
X *    Memory is allocated.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_SplitList(interp, list, argcPtr, argvPtr)
X    Tcl_Interp *interp;        /* Interpreter to use for error reporting. */
X    char *list;            /* Pointer to string with list structure. */
X    int *argcPtr;        /* Pointer to location to fill in with
X                 * the number of elements in the list. */
X    char ***argvPtr;        /* Pointer to place to store pointer to array
X                 * of pointers to list elements. */
X{
X    char **argv;
X    register char *p;
X    int size, i, result, elSize, brace;
X    char *element;
X
X    /*
X     * Figure out how much space to allocate.  There must be enough
X     * space for both the array of pointers and also for a copy of
X     * the list.  To estimate the number of pointers needed, count
X     * the number of space characters in the list.
X     */
X
X    for (size = 1, p = list; *p != 0; p++) {
X    if (isspace(*p)) {
X        size++;
X    }
X    }
X    size++;            /* Leave space for final NULL pointer. */
X    argv = (char **) ckalloc((unsigned)
X        ((size * sizeof(char *)) + (p - list) + 1));
X    for (i = 0, p = ((char *) argv) + size*sizeof(char *);
X        *list != 0; i++) {
X    result = TclFindElement(interp, list, &element, &list, &elSize, &brace);
X    if (result != TCL_OK) {
X        ckfree((char *) argv);
X        return result;
X    }
X    if (*element == 0) {
X        break;
X    }
X    if (i >= size) {
X        ckfree((char *) argv);
X        Tcl_SetResult(interp, "internal error in Tcl_SplitList",
X            TCL_STATIC);
X        return TCL_ERROR;
X    }
X    argv[i] = p;
X    if (brace) {
X        strncpy(p, element, elSize);
X        p += elSize;
X        *p = 0;
X        p++;
X    } else {
X        TclCopyAndCollapse(elSize, element, p);
X        p += elSize+1;
X    }
X    }
X
X    argv[i] = NULL;
X    *argvPtr = argv;
X    *argcPtr = i;
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ScanElement --
X *
X *    This procedure is a companion procedure to Tcl_ConvertElement.
X *    It scans a string to see what needs to be done to it (e.g.
X *    add backslashes or enclosing braces) to make the string into
X *    a valid Tcl list element.
X *
X * Results:
X *    The return value is an overestimate of the number of characters
X *    that will be needed by Tcl_ConvertElement to produce a valid
X *    list element from string.  The word at *flagPtr is filled in
X *    with a value needed by Tcl_ConvertElement when doing the actual
X *    conversion.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_ScanElement(string, flagPtr)
X    char *string;        /* String to convert to Tcl list element. */
X    int *flagPtr;        /* Where to store information to guide
X                 * Tcl_ConvertElement. */
X{
X    int flags, nestingLevel;
X    register char *p;
X
X    /*
X     * This procedure and Tcl_ConvertElement together do two things:
X     *
X     * 1. They produces a proper list, one that will yield back the
X     * argument strings when evaluated or when disassembled with
X     * Tcl_SplitList.  This is the most important thing.
X     *
X     * 2. They try to produce legible output, which means minimizing the
X     * use of backslashes (using braces instead).  However, there are
X     * some situations where backslashes must be used (e.g. an element
X     * like "{abc": the leading brace will have to be backslashed.  For
X     * each element, one of three things must be done:
X     *
X     * (a) Use the element as-is (it doesn't contain anything special
X     * characters).  This is the most desirable option.
X     *
X     * (b) Enclose the element in braces, but leave the contents alone.
X     * This happens if the element contains embedded space, or if it
X     * contains characters with special interpretation ($, [, ;, or \),
X     * or if it starts with a brace or double-quote, or if there are
X     * no characters in the element.
X     *
X     * (c) Don't enclose the element in braces, but add backslashes to
X     * prevent special interpretation of special characters.  This is a
X     * last resort used when the argument would normally fall under case
X     * (b) but contains unmatched braces.  It also occurs if the last
X     * character of the argument is a backslash.
X     *
X     * The procedure figures out how many bytes will be needed to store
X     * the result (actually, it overestimates).  It also collects information
X     * about the element in the form of a flags word.
X     */
X
X    nestingLevel = 0;
X    flags = 0;
X    p = string;
X    if ((*p == '{') || (*p == '"') || (*p == 0)) {
X    flags |= USE_BRACES;
X    }
X    for ( ; *p != 0; p++) {
X    switch (*p) {
X        case '{':
X        nestingLevel++;
X        break;
X        case '}':
X        nestingLevel--;
X        if (nestingLevel < 0) {
X            flags |= CANT_USE_BRACES;
X        }
X        break;
X        case '[':
X        case '$':
X        case ';':
X        case ' ':
X        case '\f':
X        case '\n':
X        case '\r':
X        case '\t':
X        case '\v':
X        flags |= USE_BRACES;
X        break;
X        case '\\':
X        if (p[1] == 0) {
X            flags = CANT_USE_BRACES;
X        } else {
X            int size;
X
X            (void) Tcl_Backslash(p, &size);
X            p += size-1;
X            flags |= USE_BRACES;
X        }
X        break;
X    }
X    }
X    if ((nestingLevel != 0) || (flags & CANT_USE_BRACES)) {
X    flags = CANT_USE_BRACES;
X    }
X    *flagPtr = flags;
X
X    /*
X     * Allow enough space to backslash every character plus leave
X     * two spaces for braces.
X     */
X
X    return 2*(p-string) + 2;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ConvertElement --
X *
X *    This is a companion procedure to Tcl_ScanElement.  Given the
X *    information produced by Tcl_ScanElement, this procedure converts
X *    a string to a list element equal to that string.
X *
X * Results:
X *    Information is copied to *dst in the form of a list element
X *    identical to src (i.e. if Tcl_SplitList is applied to dst it
X *    will produce a string identical to src).  The return value is
X *    a count of the number of characters copied (not including the
X *    terminating NULL character).
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_ConvertElement(src, dst, flags)
X    register char *src;        /* Source information for list element. */
X    char *dst;            /* Place to put list-ified element. */
X    int flags;            /* Flags produced by Tcl_ScanElement. */
X{
X    register char *p = dst;
X
X    /*
X     * See the comment block at the beginning of the Tcl_ScanElement
X     * code for details of how this works.
X     */
X
X    if (flags & USE_BRACES) {
X    *p = '{';
X    p++;
X    for ( ; *src != 0; src++, p++) {
X        *p = *src;
X    }
X    *p = '}';
X    p++;
X    } else {
X    /*
X     * Must backslash a leading open brace, but after that don't
X     * need to worry about either open or close braces.
X     */
X
X    if (*src == '{') {
X        *p = '\\';
X        p++;
X    }
X    for (; *src != 0 ; src++) {
X        switch (*src) {
X        case ']':
X        case '[':
X        case '$':
X        case ';':
X        case ' ':
X        case '\\':
X            *p = '\\';
X            p++;
X            break;
X        case '\f':
X            *p = '\\';
X            p++;
X            *p = 'f';
X            p++;
X            continue;
X        case '\n':
X            *p = '\\';
X            p++;
X            *p = 'n';
X            p++;
X            continue;
X        case '\r':
X            *p = '\\';
X            p++;
X            *p = 'r';
X            p++;
X            continue;
X        case '\t':
X            *p = '\\';
X            p++;
X            *p = 't';
X            p++;
X            continue;
X        case '\v':
X            *p = '\\';
X            p++;
X            *p = 'v';
X            p++;
X            continue;
X        }
X        *p = *src;
X        p++;
X    }
X    }
X    *p = '\0';
X    return p-dst;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Merge --
X *
X *    Given a collection of strings, merge them together into a
X *    single string that has proper Tcl list structured (i.e.
X *    Tcl_SplitList may be used to retrieve strings equal to the
X *    original elements, and Tcl_Eval will parse the string back
X *    into its original elements).
X *
X * Results:
X *    The return value is the address of a dynamically-allocated
X *    string containing the merged list.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_Merge(argc, argv)
X    int argc;            /* How many strings to merge. */
X    char **argv;        /* Array of string values. */
X{
X#   define LOCAL_SIZE 20
X    int localFlags[LOCAL_SIZE], *flagPtr;
X    int numChars;
X    char *result;
X    register char *dst;
X    int i;
X
X    /*
X     * Pass 1: estimate space, gather flags.
X     */
X
X    if (argc <= LOCAL_SIZE) {
X    flagPtr = localFlags;
X    } else {
X    flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
X    }
X    numChars = 1;
X    for (i = 0; i < argc; i++) {
X    numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1;
X    }
X
X    /*
X     * Pass two: copy into the result area.
X     */
X
X    result = (char *) ckalloc((unsigned) numChars);
X    dst = result;
X    for (i = 0; i < argc; i++) {
X    numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]);
X    dst += numChars;
X    *dst = ' ';
X    dst++;
X    }
X    if (dst == result) {
X    *dst = 0;
X    } else {
X    dst[-1] = 0;
X    }
X
X    if (flagPtr != localFlags) {
X    ckfree((char *) flagPtr);
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_Concat --
X *
X *    Concatenate a set of strings into a single large string.
X *
X * Results:
X *    The return value is dynamically-allocated string containing
X *    a concatenation of all the strings in argv, with spaces between
X *    the original argv elements.
X *
X * Side effects:
X *    Memory is allocated for the result;  the caller is responsible
X *    for freeing the memory.
X *
X *----------------------------------------------------------------------
X */
X
Xchar *
XTcl_Concat(argc, argv)
X    int argc;            /* Number of strings to concatenate. */
X    char **argv;        /* Array of strings to concatenate. */
X{
X    int totalSize, i;
X    register char *p;
X    char *result;
X
X    for (totalSize = 1, i = 0; i < argc; i++) {
X    totalSize += strlen(argv[i]) + 1;
X    }
X    result = (char *) ckalloc((unsigned) totalSize);
X    if (argc == 0) {
X    *result = '\0';
X    return result;
X    }
X    for (p = result, i = 0; i < argc; i++) {
X    char *element;
X    int length;
X
X    /*
X     * Clip white space off the front and back of the string
X     * to generate a neater result, and ignore any empty
X     * elements.
X     */
X
X    element = argv[i];
X    while (isspace(*element)) {
X        element++;
X    }
X    for (length = strlen(element);
X        (length > 0) && (isspace(element[length-1]));
X        length--) {
X        /* Null loop body. */
X    }
X    if (length == 0) {
X        continue;
X    }
X    (void) strncpy(p, element, length);
X    p += length;
X    *p = ' ';
X    p++;
X    }
X    if (p != result) {
X    p[-1] = 0;
X    } else {
X    *p = 0;
X    }
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_StringMatch --
X *
X *    See if a particular string matches a particular pattern.
X *
X * Results:
X *    The return value is 1 if string matches pattern, and
X *    0 otherwise.  The matching operation permits the following
X *    special characters in the pattern: *?\[] (see the manual
X *    entry for details on what these mean).
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTcl_StringMatch(string, pattern)
X    register char *string;    /* String. */
X    register char *pattern;    /* Pattern, which may contain
X                 * special characters. */
X{
X    char c2;
X
X    while (1) {
X    /* See if we're at the end of both the pattern and the string.
X     * If so, we succeeded.  If we're at the end of the pattern
X     * but not at the end of the string, we failed.
X     */
X
X    if (*pattern == 0) {
X        if (*string == 0) {
X        return 1;
X        } else {
X        return 0;
X        }
X    }
X    if ((*string == 0) && (*pattern != '*')) {
X        return 0;
X    }
X
X    /* Check for a "*" as the next pattern character.  It matches
X     * any substring.  We handle this by calling ourselves
X     * recursively for each postfix of string, until either we
X     * match or we reach the end of the string.
X     */
X
X    if (*pattern == '*') {
X        pattern += 1;
X        if (*pattern == 0) {
X        return 1;
X        }
X        while (*string != 0) {
X        if (Tcl_StringMatch(string, pattern)) {
X            return 1;
X        }
X        string += 1;
X        }
X        return 0;
X    }
X
X    /* Check for a "?" as the next pattern character.  It matches
X     * any single character.
X     */
X
X    if (*pattern == '?') {
X        goto thisCharOK;
X    }
X
X    /* Check for a "[" as the next pattern character.  It is followed
X     * by a list of characters that are acceptable, or by a range
X     * (two characters separated by "-").
X     */
X
X    if (*pattern == '[') {
X        pattern += 1;
X        while (1) {
X        if ((*pattern == ']') || (*pattern == 0)) {
X            return 0;
X        }
X        if (*pattern == *string) {
X            break;
X        }
X        if (pattern[1] == '-') {
X            c2 = pattern[2];
X            if (c2 == 0) {
X            return 0;
X            }
X            if ((*pattern <= *string) && (c2 >= *string)) {
X            break;
X            }
X            if ((*pattern >= *string) && (c2 <= *string)) {
X            break;
X            }
X            pattern += 2;
X        }
X        pattern += 1;
X        }
X        while ((*pattern != ']') && (*pattern != 0)) {
X        pattern += 1;
X        }
X        goto thisCharOK;
X    }
X
X    /* If the next pattern character is '/', just strip off the '/'
X     * so we do exact matching on the character that follows.
X     */
X
X    if (*pattern == '\\') {
X        pattern += 1;
X        if (*pattern == 0) {
X        return 0;
X        }
X    }
X
X    /* There's no special character.  Just make sure that the next
X     * characters of each string match.
X     */
X
X    if (*pattern != *string) {
X        return 0;
X    }
X
X    thisCharOK: pattern += 1;
X    string += 1;
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetResult --
X *
X *    Arrange for "string" to be the Tcl return value.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    interp->result is left pointing either to "string" (if "copy" is 0)
X *    or to a copy of string.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_SetResult(interp, string, freeProc)
X    Tcl_Interp *interp;        /* Interpreter with which to associate the
X                 * return value. */
X    char *string;        /* Value to be returned.  If NULL,
X                 * the result is set to an empty string. */
X    Tcl_FreeProc *freeProc;    /* Gives information about the string:
X                 * TCL_STATIC, TCL_VOLATILE, or the address
X                 * of a Tcl_FreeProc such as free. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int length;
X    Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
X    char *oldResult = iPtr->result;
X
X    iPtr->freeProc = freeProc;
X    if (string == NULL) {
X    iPtr->resultSpace[0] = 0;
X    iPtr->result = iPtr->resultSpace;
X    iPtr->freeProc = 0;
X    } else if (freeProc == TCL_VOLATILE) {
X    length = strlen(string);
X    if (length > TCL_RESULT_SIZE) {
X        iPtr->result = (char *) ckalloc((unsigned) length+1);
X        iPtr->freeProc = (Tcl_FreeProc *) free;
X    } else {
X        iPtr->result = iPtr->resultSpace;
X        iPtr->freeProc = 0;
X    }
X    strcpy(iPtr->result, string);
X    } else {
X    iPtr->result = string;
X    }
X
X    /*
X     * If the old result was dynamically-allocated, free it up.  Do it
X     * here, rather than at the beginning, in case the new result value
X     * was part of the old result value.
X     */
X
X    if (oldFreeProc != 0) {
X    (*oldFreeProc)(oldResult);
X    }
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AppendResult --
X *
X *    Append a variable number of strings onto the result already
X *    present for an interpreter.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The result in the interpreter given by the first argument
X *    is extended by the strings given by the second and following
X *    arguments (up to a terminating NULL argument).
X *
X *----------------------------------------------------------------------
X */
X
X    /* VARARGS2 */
X#ifndef lint
Xvoid
XTcl_AppendResult(va_alist)
X#else
Xvoid
X    /* VARARGS2 */ /* ARGSUSED */
XTcl_AppendResult(interp, p, va_alist)
X    Tcl_Interp *interp;        /* Interpreter whose result is to be
X                 * extended. */
X    char *p;            /* One or more strings to add to the
X                 * result, terminated with NULL. */
X#endif
X    va_dcl
X{
X    va_list argList;
X    register Interp *iPtr;
X    char *string;
X    int newSpace;
X
X    /*
X     * First, scan through all the arguments to see how much space is
X     * needed.
X     */
X
X    va_start(argList);
X    iPtr = va_arg(argList, Interp *);
X    newSpace = 0;
X    while (1) {
X    string = va_arg(argList, char *);
X    if (string == NULL) {
X        break;
X    }
X    newSpace += strlen(string);
X    }
X    va_end(argList);
X
X    /*
X     * If the append buffer isn't already setup and large enough
X     * to hold the new data, set it up.
X     */
X
X    if ((iPtr->result != iPtr->appendResult)
X       || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) {
X       SetupAppendBuffer(iPtr, newSpace);
X    }
X
X    /*
X     * Final step:  go through all the argument strings again, copying
X     * them into the buffer.
X     */
X
X    va_start(argList);
X    (void) va_arg(argList, Tcl_Interp *);
X    while (1) {
X    string = va_arg(argList, char *);
X    if (string == NULL) {
X        break;
X    }
X    strcpy(iPtr->appendResult + iPtr->appendUsed, string);
X    iPtr->appendUsed += strlen(string);
X    }
X    va_end(argList);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_AppendElement --
X *
X *    Convert a string to a valid Tcl list element and append it
X *    to the current result (which is ostensibly a list).
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The result in the interpreter given by the first argument
X *    is extended with a list element converted from string.  If
X *    the original result wasn't empty, then a blank is added before
X *    the converted list element.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_AppendElement(interp, string, noSep)
X    Tcl_Interp *interp;        /* Interpreter whose result is to be
X                 * extended. */
X    char *string;        /* String to convert to list element and
X                 * add to result. */
X    int noSep;            /* If non-zero, then don't output a
X                 * space character before this element,
X                 * even if the element isn't the first
X                 * thing in the output buffer. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int size, flags;
X    char *dst;
X
X    /*
X     * See how much space is needed, and grow the append buffer if
X     * needed to accommodate the list element.
X     */
X
X    size = Tcl_ScanElement(string, &flags) + 1;
X    if ((iPtr->result != iPtr->appendResult)
X       || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) {
X       SetupAppendBuffer(iPtr, size+iPtr->appendUsed);
X    }
X
X    /*
X     * Convert the string into a list element and copy it to the
X     * buffer that's forming.
X     */
X
X    dst = iPtr->appendResult + iPtr->appendUsed;
X    if (!noSep && (iPtr->appendUsed != 0)) {
X    iPtr->appendUsed++;
X    *dst = ' ';
X    dst++;
X    }
X    iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * SetupAppendBuffer --
X *
X *    This procedure makes sure that there is an append buffer
X *    properly initialized for interp, and that it has at least
X *    enough room to accommodate newSpace new bytes of information.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xstatic void
XSetupAppendBuffer(iPtr, newSpace)
X    register Interp *iPtr;    /* Interpreter whose result is being set up. */
X    int newSpace;        /* Make sure that at least this many bytes
X                 * of new information may be added. */
X{
X    int totalSpace;
X
X    /*
X     * Make the append buffer larger, if that's necessary, then
X     * copy the current result into the append buffer and make the
X     * append buffer the official Tcl result.
X     */
X
X    if (iPtr->result != iPtr->appendResult) {
X    /*
X     * If an oversized buffer was used recently, then free it up
X     * so we go back to a smaller buffer.  This avoids tying up
X     * memory forever after a large operation.
X     */
X
X    if (iPtr->appendAvl > 500) {
X        ckfree(iPtr->appendResult);
X        iPtr->appendResult = NULL;
X        iPtr->appendAvl = 0;
X    }
X    iPtr->appendUsed = strlen(iPtr->result);
X    }
X    totalSpace = newSpace + iPtr->appendUsed;
X    if (totalSpace >= iPtr->appendAvl) {
X    char *new;
X
X    if (totalSpace < 100) {
X        totalSpace = 200;
X    } else {
X        totalSpace *= 2;
X    }
X    new = (char *) ckalloc((unsigned) totalSpace);
X    strcpy(new, iPtr->result);
X    if (iPtr->appendResult != NULL) {
X        ckfree(iPtr->appendResult);
X    }
X    iPtr->appendResult = new;
X    iPtr->appendAvl = totalSpace;
X    } else if (iPtr->result != iPtr->appendResult) {
X    strcpy(iPtr->appendResult, iPtr->result);
X    }
X    Tcl_FreeResult(iPtr);
X    iPtr->result = iPtr->appendResult;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_ResetResult --
X *
X *    This procedure restores the result area for an interpreter
X *    to its default initialized state, freeing up any memory that
X *    may have been allocated for the result and clearing any
X *    error information for the interpreter.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
XTcl_ResetResult(interp)
X    Tcl_Interp *interp;        /* Interpreter for which to clear result. */
X{
X    register Interp *iPtr = (Interp *) interp;
X
X    Tcl_FreeResult(iPtr);
X    iPtr->result = iPtr->resultSpace;
X    iPtr->resultSpace[0] = 0;
X    iPtr->flags &=
X        ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET);
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * Tcl_SetErrorCode --
X *
X *    This procedure is called to record machine-readable information
X *    about an error that is about to be returned.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The errorCode global variable is modified to hold all of the
X *    arguments to this procedure, in a list form with each argument
X *    becoming one element of the list.  A flag is set internally
X *    to remember that errorCode has been set, so the variable doesn't
X *    get set automatically when the error is returned.
X *
X *----------------------------------------------------------------------
X */
X    /* VARARGS2 */
X#ifndef lint
Xvoid
XTcl_SetErrorCode(va_alist)
X#else
Xvoid
X    /* VARARGS2 */ /* ARGSUSED */
XTcl_SetErrorCode(interp, p, va_alist)
X    Tcl_Interp *interp;        /* Interpreter whose errorCode variable is
X                 * to be set. */
X    char *p;            /* One or more elements to add to errorCode,
X                 * terminated with NULL. */
X#endif
X    va_dcl
X{
X    va_list argList;
X    char *string;
X    int flags;
X    Interp *iPtr;
X
X    /*
X     * Scan through the arguments one at a time, appending them to
X     * $errorCode as list elements.
X     */
X
X    va_start(argList);
X    iPtr = va_arg(argList, Interp *);
X    flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT;
X    while (1) {
X    string = va_arg(argList, char *);
X    if (string == NULL) {
X        break;
X    }
X    (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode",
X        (char *) NULL, string, flags);
X    flags |= TCL_APPEND_VALUE;
X    }
X    va_end(argList);
X    iPtr->flags |= ERROR_CODE_SET;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclGetListIndex --
X *
X *    Parse a list index, which may be either an integer or the
X *    value "end".
X *
X * Results:
X *    The return value is either TCL_OK or TCL_ERROR.  If it is
X *    TCL_OK, then the index corresponding to string is left in
X *    *indexPtr.  If the return value is TCL_ERROR, then string
X *    was bogus;  an error message is returned in interp->result.
X *    If a negative index is specified, it is rounded up to 0.
X *    The index value may be larger than the size of the list
X *    (this happens when "end" is specified).
X *
X * Side effects:
X *    None.
X *
X *----------------------------------------------------------------------
X */
X
Xint
XTclGetListIndex(interp, string, indexPtr)
X    Tcl_Interp *interp;            /* Interpreter for error reporting. */
X    char *string;            /* String containing list index. */
X    int *indexPtr;            /* Where to store index. */
X{
X    if (isdigit(*string) || (*string == '-')) {
X    if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) {
X        return TCL_ERROR;
X    }
X    if (*indexPtr < 0) {
X        *indexPtr = 0;
X    }
X    } else if (strncmp(string, "end", strlen(string)) == 0) {
X    *indexPtr = 1<<30;
X    } else {
X    Tcl_AppendResult(interp, "bad index \"", string,
X        "\": must be integer or \"end\"", (char *) NULL);
X    return TCL_ERROR;
X    }
X    return TCL_OK;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * TclCompileRegexp --
X *
X *    Compile a regular expression into a form suitable for fast
X *    matching.  This procedure retains a small cache of pre-compiled
X *    regular expressions in the interpreter, in order to avoid
X *    compilation costs as much as possible.
X *
X * Results:
X *    The return value is a pointer to the compiled form of string,
X *    suitable for passing to regexec.  If an error occurred while
X *    compiling the pattern, then NULL is returned and an error
X *    message is left in interp->result.
X *
X * Side effects:
X *    The cache of compiled regexp's in interp will be modified to
X *    hold information for string, if such information isn't already
X *    present in the cache.
X *
X *----------------------------------------------------------------------
X */
X
Xregexp *
XTclCompileRegexp(interp, string)
X    Tcl_Interp *interp;            /* For use in error reporting. */
X    char *string;            /* String for which to produce
X                     * compiled regular expression. */
X{
X    register Interp *iPtr = (Interp *) interp;
X    int i, length;
X    regexp *result;
X
X    length = strlen(string);
X    for (i = 0; i < NUM_REGEXPS; i++) {
X    if ((length == iPtr->patLengths[i])
X        && (strcmp(string, iPtr->patterns[i]) == 0)) {
X        /*
X         * Move the matched pattern to the first slot in the
X         * cache and shift the other patterns down one position.
X         */
X
X        if (i != 0) {
X        int j;
X        char *cachedString;
X
X        cachedString = iPtr->patterns[i];
X        result = iPtr->regexps[i];
X        for (j = i-1; j >= 0; j--) {
X            iPtr->patterns[j+1] = iPtr->patterns[j];
X            iPtr->patLengths[j+1] = iPtr->patLengths[j];
X            iPtr->regexps[j+1] = iPtr->regexps[j];
X        }
X        iPtr->patterns[0] = cachedString;
X        iPtr->patLengths[0] = length;
X        iPtr->regexps[0] = result;
X        }
X        return iPtr->regexps[0];
X    }
X    }
X
X    /*
X     * No match in the cache.  Compile the string and add it to the
X     * cache.
X     */
X
X    tclRegexpError = NULL;
X    result = regcomp(string);
X    if (tclRegexpError != NULL) {
X    Tcl_AppendResult(interp,
X        "couldn't compile regular expression pattern: ",
X        tclRegexpError, (char *) NULL);
X    return NULL;
X    }
X    if (iPtr->patterns[NUM_REGEXPS-1] != NULL) {
X    ckfree(iPtr->patterns[NUM_REGEXPS-1]);
X    ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]);
X    }
X    for (i = NUM_REGEXPS - 2; i >= 0; i--) {
X    iPtr->patterns[i+1] = iPtr->patterns[i];
X    iPtr->patLengths[i+1] = iPtr->patLengths[i];
X    iPtr->regexps[i+1] = iPtr->regexps[i];
X    }
X    iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1));
X    strcpy(iPtr->patterns[0], string);
X    iPtr->patLengths[0] = length;
X    iPtr->regexps[0] = result;
X    return result;
X}
X
X/*
X *----------------------------------------------------------------------
X *
X * regerror --
X *
X *    This procedure is invoked by the Henry Spencer's regexp code
X *    when an error occurs.  It saves the error message so it can
X *    be seen by the code that called Spencer's code.
X *
X * Results:
X *    None.
X *
X * Side effects:
X *    The value of "string" is saved in "tclRegexpError".
X *
X *----------------------------------------------------------------------
X */
X
Xvoid
Xregerror(string)
X    char *string;            /* Error message. */
X{
X    tclRegexpError = string;
X}
END_OF_FILE
if test 36390 -ne `wc -c <'tcl6.1/tclUtil.c'`; then
    echo shar: \"'tcl6.1/tclUtil.c'\" unpacked with wrong size!
fi
# end of 'tcl6.1/tclUtil.c'
fi
echo shar: End of archive 29 \(of 33\).
cp /dev/null ark29isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 33 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0

exit 0 # Just in case...
--
Kent Landfield                   INTERNET: [e-mail]
Sterling Software, IMD           UUCP:     uunet!sparky!kent
Phone:    [phone]         FAX:      [phone]
Please send comp.sources.misc-related mail to [e-mail].