diff options
Diffstat (limited to 'contrib/tcl/generic/tclUtil.c')
| -rw-r--r-- | contrib/tcl/generic/tclUtil.c | 2133 |
1 files changed, 2133 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c new file mode 100644 index 0000000..5f83c58 --- /dev/null +++ b/contrib/tcl/generic/tclUtil.c @@ -0,0 +1,2133 @@ +/* + * tclUtil.c -- + * + * This file contains utility procedures that are used by many Tcl + * commands. + * + * Copyright (c) 1987-1993 The Regents of the University of California. + * Copyright (c) 1994-1995 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * SCCS: @(#) tclUtil.c 1.112 96/02/15 11:42:52 + */ + +#include "tclInt.h" +#include "tclPort.h" + +/* + * The following values are used in the flags returned by Tcl_ScanElement + * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also + * defined in tcl.h; make sure its value doesn't overlap with any of the + * values below. + * + * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in + * braces (e.g. it contains unmatched braces, + * or ends in a backslash character, or user + * just doesn't want braces); handle all + * special characters by adding backslashes. + * USE_BRACES - 1 means the string contains a special + * character that can be handled simply by + * enclosing the entire argument in braces. + * BRACES_UNMATCHED - 1 means that braces aren't properly matched + * in the argument. + */ + +#define USE_BRACES 2 +#define BRACES_UNMATCHED 4 + +/* + * Function prototypes for local procedures in this file: + */ + +static void SetupAppendBuffer _ANSI_ARGS_((Interp *iPtr, + int newSpace)); + +/* + *---------------------------------------------------------------------- + * + * TclFindElement -- + * + * Given a pointer into a Tcl list, locate the first (or next) + * element in the list. + * + * Results: + * The return value is normally TCL_OK, which means that the + * element was successfully located. If TCL_ERROR is returned + * it means that list didn't have proper list structure; + * interp->result contains a more detailed error message. + * + * If TCL_OK is returned, then *elementPtr will be set to point + * to the first element of list, and *nextPtr will be set to point + * to the character just after any white space following the last + * character that's part of the element. If this is the last argument + * in the list, then *nextPtr will point to the NULL character at the + * end of list. If sizePtr is non-NULL, *sizePtr is filled in with + * the number of characters in the element. If the element is in + * braces, then *elementPtr will point to the character after the + * opening brace and *sizePtr will not include either of the braces. + * If there isn't an element in the list, *sizePtr will be zero, and + * both *elementPtr and *termPtr will refer to the null character at + * the end of list. Note: this procedure does NOT collapse backslash + * sequences. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFindElement(interp, list, elementPtr, nextPtr, sizePtr, bracePtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left + * after errors. */ + register char *list; /* String containing Tcl list with zero + * or more elements (possibly in braces). */ + char **elementPtr; /* Fill in with location of first significant + * character in first element of list. */ + char **nextPtr; /* Fill in with location of character just + * after all white space following end of + * argument (i.e. next argument or end of + * list). */ + int *sizePtr; /* If non-zero, fill in with size of + * element. */ + int *bracePtr; /* If non-zero fill in with non-zero/zero + * to indicate that arg was/wasn't + * in braces. */ +{ + register char *p; + int openBraces = 0; + int inQuotes = 0; + int size; + + /* + * Skim off leading white space and check for an opening brace or + * quote. Note: use of "isascii" below and elsewhere in this + * procedure is a temporary hack (7/27/90) because Mx uses characters + * with the high-order bit set for some things. This should probably + * be changed back eventually, or all of Tcl should call isascii. + */ + + while (isspace(UCHAR(*list))) { + list++; + } + if (*list == '{') { + openBraces = 1; + list++; + } else if (*list == '"') { + inQuotes = 1; + list++; + } + if (bracePtr != 0) { + *bracePtr = openBraces; + } + p = list; + + /* + * Find the end of the element (either a space or a close brace or + * the end of the string). + */ + + while (1) { + switch (*p) { + + /* + * Open brace: don't treat specially unless the element is + * in braces. In this case, keep a nesting count. + */ + + case '{': + if (openBraces != 0) { + openBraces++; + } + break; + + /* + * Close brace: if element is in braces, keep nesting + * count and quit when the last close brace is seen. + */ + + case '}': + if (openBraces == 1) { + char *p2; + + size = p - list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in braces followed by \"%.*s\" instead of space", + (int) (p2-p), p); + } + return TCL_ERROR; + } else if (openBraces != 0) { + openBraces--; + } + break; + + /* + * Backslash: skip over everything up to the end of the + * backslash sequence. + */ + + case '\\': { + int size; + + (void) Tcl_Backslash(p, &size); + p += size - 1; + break; + } + + /* + * Space: ignore if element is in braces or quotes; otherwise + * terminate element. + */ + + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + if ((openBraces == 0) && !inQuotes) { + size = p - list; + goto done; + } + break; + + /* + * Double-quote: if element is in quotes then terminate it. + */ + + case '"': + if (inQuotes) { + char *p2; + + size = p-list; + p++; + if (isspace(UCHAR(*p)) || (*p == 0)) { + goto done; + } + for (p2 = p; (*p2 != 0) && (!isspace(UCHAR(*p2))) + && (p2 < p+20); p2++) { + /* null body */ + } + if (interp != NULL) { + Tcl_ResetResult(interp); + sprintf(interp->result, + "list element in quotes followed by \"%.*s\" %s", (int) (p2-p), p, + "instead of space"); + } + return TCL_ERROR; + } + break; + + /* + * End of list: terminate element. + */ + + case 0: + if (openBraces != 0) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open brace in list", + TCL_STATIC); + } + return TCL_ERROR; + } else if (inQuotes) { + if (interp != NULL) { + Tcl_SetResult(interp, "unmatched open quote in list", + TCL_STATIC); + } + return TCL_ERROR; + } + size = p - list; + goto done; + + } + p++; + } + + done: + while (isspace(UCHAR(*p))) { + p++; + } + *elementPtr = list; + *nextPtr = p; + if (sizePtr != 0) { + *sizePtr = size; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCopyAndCollapse -- + * + * Copy a string and eliminate any backslashes that aren't in braces. + * + * Results: + * There is no return value. Count chars. get copied from src + * to dst. Along the way, if backslash sequences are found outside + * braces, the backslashes are eliminated in the copy. + * After scanning count chars. from source, a null character is + * placed at the end of dst. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclCopyAndCollapse(count, src, dst) + int count; /* Total number of characters to copy + * from src. */ + register char *src; /* Copy from here... */ + register char *dst; /* ... to here. */ +{ + register char c; + int numRead; + + for (c = *src; count > 0; src++, c = *src, count--) { + if (c == '\\') { + *dst = Tcl_Backslash(src, &numRead); + dst++; + src += numRead-1; + count -= numRead-1; + } else { + *dst = c; + dst++; + } + } + *dst = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SplitList -- + * + * Splits a list up into its constituent fields. + * + * Results + * The return value is normally TCL_OK, which means that + * the list was successfully split up. If TCL_ERROR is + * returned, it means that "list" didn't have proper list + * structure; interp->result will contain a more detailed + * error message. + * + * *argvPtr will be filled in with the address of an array + * whose elements point to the elements of list, in order. + * *argcPtr will get filled in with the number of valid elements + * in the array. A single block of memory is dynamically allocated + * to hold both the argv array and a copy of the list (with + * backslashes and braces removed in the standard way). + * The caller must eventually free this memory by calling free() + * on *argvPtr. Note: *argvPtr and *argcPtr are only modified + * if the procedure returns normally. + * + * Side effects: + * Memory is allocated. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_SplitList(interp, list, argcPtr, argvPtr) + Tcl_Interp *interp; /* Interpreter to use for error reporting. + * If NULL, then no error message is left. */ + char *list; /* Pointer to string with list structure. */ + int *argcPtr; /* Pointer to location to fill in with + * the number of elements in the list. */ + char ***argvPtr; /* Pointer to place to store pointer to array + * of pointers to list elements. */ +{ + char **argv; + register char *p; + int size, i, result, elSize, brace; + char *element; + + /* + * Figure out how much space to allocate. There must be enough + * space for both the array of pointers and also for a copy of + * the list. To estimate the number of pointers needed, count + * the number of space characters in the list. + */ + + for (size = 1, p = list; *p != 0; p++) { + if (isspace(UCHAR(*p))) { + size++; + } + } + size++; /* Leave space for final NULL pointer. */ + argv = (char **) ckalloc((unsigned) + ((size * sizeof(char *)) + (p - list) + 1)); + for (i = 0, p = ((char *) argv) + size*sizeof(char *); + *list != 0; i++) { + result = TclFindElement(interp, list, &element, &list, &elSize, &brace); + if (result != TCL_OK) { + ckfree((char *) argv); + return result; + } + if (*element == 0) { + break; + } + if (i >= size) { + ckfree((char *) argv); + if (interp != NULL) { + Tcl_SetResult(interp, "internal error in Tcl_SplitList", + TCL_STATIC); + } + return TCL_ERROR; + } + argv[i] = p; + if (brace) { + strncpy(p, element, (size_t) elSize); + p += elSize; + *p = 0; + p++; + } else { + TclCopyAndCollapse(elSize, element, p); + p += elSize+1; + } + } + + argv[i] = NULL; + *argvPtr = argv; + *argcPtr = i; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ScanElement -- + * + * This procedure is a companion procedure to Tcl_ConvertElement. + * It scans a string to see what needs to be done to it (e.g. + * add backslashes or enclosing braces) to make the string into + * a valid Tcl list element. + * + * Results: + * The return value is an overestimate of the number of characters + * that will be needed by Tcl_ConvertElement to produce a valid + * list element from string. The word at *flagPtr is filled in + * with a value needed by Tcl_ConvertElement when doing the actual + * conversion. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ScanElement(string, flagPtr) + char *string; /* String to convert to Tcl list element. */ + int *flagPtr; /* Where to store information to guide + * Tcl_ConvertElement. */ +{ + int flags, nestingLevel; + register char *p; + + /* + * This procedure and Tcl_ConvertElement together do two things: + * + * 1. They produce a proper list, one that will yield back the + * argument strings when evaluated or when disassembled with + * Tcl_SplitList. This is the most important thing. + * + * 2. They try to produce legible output, which means minimizing the + * use of backslashes (using braces instead). However, there are + * some situations where backslashes must be used (e.g. an element + * like "{abc": the leading brace will have to be backslashed. For + * each element, one of three things must be done: + * + * (a) Use the element as-is (it doesn't contain anything special + * characters). This is the most desirable option. + * + * (b) Enclose the element in braces, but leave the contents alone. + * This happens if the element contains embedded space, or if it + * contains characters with special interpretation ($, [, ;, or \), + * or if it starts with a brace or double-quote, or if there are + * no characters in the element. + * + * (c) Don't enclose the element in braces, but add backslashes to + * prevent special interpretation of special characters. This is a + * last resort used when the argument would normally fall under case + * (b) but contains unmatched braces. It also occurs if the last + * character of the argument is a backslash or if the element contains + * a backslash followed by newline. + * + * The procedure figures out how many bytes will be needed to store + * the result (actually, it overestimates). It also collects information + * about the element in the form of a flags word. + */ + + nestingLevel = 0; + flags = 0; + if (string == NULL) { + string = ""; + } + p = string; + if ((*p == '{') || (*p == '"') || (*p == 0)) { + flags |= USE_BRACES; + } + for ( ; *p != 0; p++) { + switch (*p) { + case '{': + nestingLevel++; + break; + case '}': + nestingLevel--; + if (nestingLevel < 0) { + flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; + } + break; + case '[': + case '$': + case ';': + case ' ': + case '\f': + case '\n': + case '\r': + case '\t': + case '\v': + flags |= USE_BRACES; + break; + case '\\': + if ((p[1] == 0) || (p[1] == '\n')) { + flags = TCL_DONT_USE_BRACES; + } else { + int size; + + (void) Tcl_Backslash(p, &size); + p += size-1; + flags |= USE_BRACES; + } + break; + } + } + if (nestingLevel != 0) { + flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; + } + *flagPtr = flags; + + /* + * Allow enough space to backslash every character plus leave + * two spaces for braces. + */ + + return 2*(p-string) + 2; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ConvertElement -- + * + * This is a companion procedure to Tcl_ScanElement. Given the + * information produced by Tcl_ScanElement, this procedure converts + * a string to a list element equal to that string. + * + * Results: + * Information is copied to *dst in the form of a list element + * identical to src (i.e. if Tcl_SplitList is applied to dst it + * will produce a string identical to src). The return value is + * a count of the number of characters copied (not including the + * terminating NULL character). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_ConvertElement(src, dst, flags) + register char *src; /* Source information for list element. */ + char *dst; /* Place to put list-ified element. */ + int flags; /* Flags produced by Tcl_ScanElement. */ +{ + register char *p = dst; + + /* + * See the comment block at the beginning of the Tcl_ScanElement + * code for details of how this works. + */ + + if ((src == NULL) || (*src == 0)) { + p[0] = '{'; + p[1] = '}'; + p[2] = 0; + return 2; + } + if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { + *p = '{'; + p++; + for ( ; *src != 0; src++, p++) { + *p = *src; + } + *p = '}'; + p++; + } else { + if (*src == '{') { + /* + * Can't have a leading brace unless the whole element is + * enclosed in braces. Add a backslash before the brace. + * Furthermore, this may destroy the balance between open + * and close braces, so set BRACES_UNMATCHED. + */ + + p[0] = '\\'; + p[1] = '{'; + p += 2; + src++; + flags |= BRACES_UNMATCHED; + } + for (; *src != 0 ; src++) { + switch (*src) { + case ']': + case '[': + case '$': + case ';': + case ' ': + case '\\': + case '"': + *p = '\\'; + p++; + break; + case '{': + case '}': + /* + * It may not seem necessary to backslash braces, but + * it is. The reason for this is that the resulting + * list element may actually be an element of a sub-list + * enclosed in braces (e.g. if Tcl_DStringStartSublist + * has been invoked), so there may be a brace mismatch + * if the braces aren't backslashed. + */ + + if (flags & BRACES_UNMATCHED) { + *p = '\\'; + p++; + } + break; + case '\f': + *p = '\\'; + p++; + *p = 'f'; + p++; + continue; + case '\n': + *p = '\\'; + p++; + *p = 'n'; + p++; + continue; + case '\r': + *p = '\\'; + p++; + *p = 'r'; + p++; + continue; + case '\t': + *p = '\\'; + p++; + *p = 't'; + p++; + continue; + case '\v': + *p = '\\'; + p++; + *p = 'v'; + p++; + continue; + } + *p = *src; + p++; + } + } + *p = '\0'; + return p-dst; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Merge -- + * + * Given a collection of strings, merge them together into a + * single string that has proper Tcl list structured (i.e. + * Tcl_SplitList may be used to retrieve strings equal to the + * original elements, and Tcl_Eval will parse the string back + * into its original elements). + * + * Results: + * The return value is the address of a dynamically-allocated + * string containing the merged list. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Merge(argc, argv) + int argc; /* How many strings to merge. */ + char **argv; /* Array of string values. */ +{ +# define LOCAL_SIZE 20 + int localFlags[LOCAL_SIZE], *flagPtr; + int numChars; + char *result; + register char *dst; + int i; + + /* + * Pass 1: estimate space, gather flags. + */ + + if (argc <= LOCAL_SIZE) { + flagPtr = localFlags; + } else { + flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); + } + numChars = 1; + for (i = 0; i < argc; i++) { + numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; + } + + /* + * Pass two: copy into the result area. + */ + + result = (char *) ckalloc((unsigned) numChars); + dst = result; + for (i = 0; i < argc; i++) { + numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); + dst += numChars; + *dst = ' '; + dst++; + } + if (dst == result) { + *dst = 0; + } else { + dst[-1] = 0; + } + + if (flagPtr != localFlags) { + ckfree((char *) flagPtr); + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_Concat -- + * + * Concatenate a set of strings into a single large string. + * + * Results: + * The return value is dynamically-allocated string containing + * a concatenation of all the strings in argv, with spaces between + * the original argv elements. + * + * Side effects: + * Memory is allocated for the result; the caller is responsible + * for freeing the memory. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_Concat(argc, argv) + int argc; /* Number of strings to concatenate. */ + char **argv; /* Array of strings to concatenate. */ +{ + int totalSize, i; + register char *p; + char *result; + + for (totalSize = 1, i = 0; i < argc; i++) { + totalSize += strlen(argv[i]) + 1; + } + result = (char *) ckalloc((unsigned) totalSize); + if (argc == 0) { + *result = '\0'; + return result; + } + for (p = result, i = 0; i < argc; i++) { + char *element; + int length; + + /* + * Clip white space off the front and back of the string + * to generate a neater result, and ignore any empty + * elements. + */ + + element = argv[i]; + while (isspace(UCHAR(*element))) { + element++; + } + for (length = strlen(element); + (length > 0) && (isspace(UCHAR(element[length-1]))); + length--) { + /* Null loop body. */ + } + if (length == 0) { + continue; + } + (void) strncpy(p, element, (size_t) length); + p += length; + *p = ' '; + p++; + } + if (p != result) { + p[-1] = 0; + } else { + *p = 0; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and + * 0 otherwise. The matching operation permits the following + * special characters in the pattern: *?\[] (see the manual + * entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_StringMatch(string, pattern) + register char *string; /* String. */ + register char *pattern; /* Pattern, which may contain + * special characters. */ +{ + char c2; + + while (1) { + /* See if we're at the end of both the pattern and the string. + * If so, we succeeded. If we're at the end of the pattern + * but not at the end of the string, we failed. + */ + + if (*pattern == 0) { + if (*string == 0) { + return 1; + } else { + return 0; + } + } + if ((*string == 0) && (*pattern != '*')) { + return 0; + } + + /* Check for a "*" as the next pattern character. It matches + * any substring. We handle this by calling ourselves + * recursively for each postfix of string, until either we + * match or we reach the end of the string. + */ + + if (*pattern == '*') { + pattern += 1; + if (*pattern == 0) { + return 1; + } + while (1) { + if (Tcl_StringMatch(string, pattern)) { + return 1; + } + if (*string == 0) { + return 0; + } + string += 1; + } + } + + /* Check for a "?" as the next pattern character. It matches + * any single character. + */ + + if (*pattern == '?') { + goto thisCharOK; + } + + /* Check for a "[" as the next pattern character. It is followed + * by a list of characters that are acceptable, or by a range + * (two characters separated by "-"). + */ + + if (*pattern == '[') { + pattern += 1; + while (1) { + if ((*pattern == ']') || (*pattern == 0)) { + return 0; + } + if (*pattern == *string) { + break; + } + if (pattern[1] == '-') { + c2 = pattern[2]; + if (c2 == 0) { + return 0; + } + if ((*pattern <= *string) && (c2 >= *string)) { + break; + } + if ((*pattern >= *string) && (c2 <= *string)) { + break; + } + pattern += 2; + } + pattern += 1; + } + while (*pattern != ']') { + if (*pattern == 0) { + pattern--; + break; + } + pattern += 1; + } + goto thisCharOK; + } + + /* If the next pattern character is '/', just strip off the '/' + * so we do exact matching on the character that follows. + */ + + if (*pattern == '\\') { + pattern += 1; + if (*pattern == 0) { + return 0; + } + } + + /* There's no special character. Just make sure that the next + * characters of each string match. + */ + + if (*pattern != *string) { + return 0; + } + + thisCharOK: pattern += 1; + string += 1; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "string" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "string" (if "copy" is 0) + * or to a copy of string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult(interp, string, freeProc) + Tcl_Interp *interp; /* Interpreter with which to associate the + * return value. */ + char *string; /* Value to be returned. If NULL, + * the result is set to an empty string. */ + Tcl_FreeProc *freeProc; /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address + * of a Tcl_FreeProc such as free. */ +{ + register Interp *iPtr = (Interp *) interp; + int length; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (string == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_DYNAMIC) { + iPtr->result = string; + iPtr->freeProc = TCL_DYNAMIC; + } else if (freeProc == TCL_VOLATILE) { + length = strlen(string); + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *) ckalloc((unsigned) length+1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + strcpy(iPtr->result, string); + } else { + iPtr->result = string; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it + * here, rather than at the beginning, in case the new result value + * was part of the old result value. + */ + + if (oldFreeProc != 0) { + if ((oldFreeProc == TCL_DYNAMIC) + || (oldFreeProc == (Tcl_FreeProc *) free)) { + ckfree(oldResult); + } else { + (*oldFreeProc)(oldResult); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendResult -- + * + * Append a variable number of strings onto the result already + * present for an interpreter. + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended by the strings given by the second and following + * arguments (up to a terminating NULL argument). + * + *---------------------------------------------------------------------- + */ + + /* VARARGS2 */ +void +Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + register Interp *iPtr; + char *string; + int newSpace; + + /* + * First, scan through all the arguments to see how much space is + * needed. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + newSpace = 0; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + newSpace += strlen(string); + } + va_end(argList); + + /* + * If the append buffer isn't already setup and large enough + * to hold the new data, set it up. + */ + + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((newSpace + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, newSpace); + } + + /* + * Final step: go through all the argument strings again, copying + * them into the buffer. + */ + + TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + strcpy(iPtr->appendResult + iPtr->appendUsed, string); + iPtr->appendUsed += strlen(string); + } + va_end(argList); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendElement -- + * + * Convert a string to a valid Tcl list element and append it + * to the current result (which is ostensibly a list). + * + * Results: + * None. + * + * Side effects: + * The result in the interpreter given by the first argument + * is extended with a list element converted from string. A + * separator space is added before the converted list element + * unless the current result is empty, contains the single + * character "{", or ends in " {". + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendElement(interp, string) + Tcl_Interp *interp; /* Interpreter whose result is to be + * extended. */ + char *string; /* String to convert to list element and + * add to result. */ +{ + register Interp *iPtr = (Interp *) interp; + int size, flags; + char *dst; + + /* + * See how much space is needed, and grow the append buffer if + * needed to accommodate the list element. + */ + + size = Tcl_ScanElement(string, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the + * buffer that's forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + } + iPtr->appendUsed += Tcl_ConvertElement(string, dst, flags); +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This procedure makes sure that there is an append buffer + * properly initialized for interp, and that it has at least + * enough room to accommodate newSpace new bytes of information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +SetupAppendBuffer(iPtr, newSpace) + register Interp *iPtr; /* Interpreter whose result is being set up. */ + int newSpace; /* Make sure that at least this many bytes + * of new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then + * copy the current result into the append buffer and make the + * append buffer the official Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up + * so we go back to a smaller buffer. This avoids tying up + * memory forever after a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. + * Just recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *new; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + new = (char *) ckalloc((unsigned) totalSpace); + strcpy(new, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = new; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->appendResult; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ResetResult -- + * + * This procedure restores the result area for an interpreter + * to its default initialized state, freeing up any memory that + * may have been allocated for the result and clearing any + * error information for the interpreter. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_ResetResult(interp) + Tcl_Interp *interp; /* Interpreter for which to clear result. */ +{ + register Interp *iPtr = (Interp *) interp; + + Tcl_FreeResult(iPtr); + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->flags &= + ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS | ERROR_CODE_SET); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This procedure is called to record machine-readable information + * about an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode global variable is modified to hold all of the + * arguments to this procedure, in a list form with each argument + * becoming one element of the list. A flag is set internally + * to remember that errorCode has been set, so the variable doesn't + * get set automatically when the error is returned. + * + *---------------------------------------------------------------------- + */ + /* VARARGS2 */ +void +Tcl_SetErrorCode TCL_VARARGS_DEF(Tcl_Interp *,arg1) +{ + va_list argList; + char *string; + int flags; + Interp *iPtr; + + /* + * Scan through the arguments one at a time, appending them to + * $errorCode as list elements. + */ + + iPtr = (Interp *) TCL_VARARGS_START(Tcl_Interp *,arg1,argList); + flags = TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT; + while (1) { + string = va_arg(argList, char *); + if (string == NULL) { + break; + } + (void) Tcl_SetVar2((Tcl_Interp *) iPtr, "errorCode", + (char *) NULL, string, flags); + flags |= TCL_APPEND_VALUE; + } + va_end(argList); + iPtr->flags |= ERROR_CODE_SET; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetListIndex -- + * + * Parse a list index, which may be either an integer or the + * value "end". + * + * Results: + * The return value is either TCL_OK or TCL_ERROR. If it is + * TCL_OK, then the index corresponding to string is left in + * *indexPtr. If the return value is TCL_ERROR, then string + * was bogus; an error message is returned in interp->result. + * If a negative index is specified, it is rounded up to 0. + * The index value may be larger than the size of the list + * (this happens when "end" is specified). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclGetListIndex(interp, string, indexPtr) + Tcl_Interp *interp; /* Interpreter for error reporting. */ + char *string; /* String containing list index. */ + int *indexPtr; /* Where to store index. */ +{ + if (isdigit(UCHAR(*string)) || (*string == '-')) { + if (Tcl_GetInt(interp, string, indexPtr) != TCL_OK) { + return TCL_ERROR; + } + if (*indexPtr < 0) { + *indexPtr = 0; + } + } else if (strncmp(string, "end", strlen(string)) == 0) { + *indexPtr = INT_MAX; + } else { + Tcl_AppendResult(interp, "bad index \"", string, + "\": must be integer or \"end\"", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpCompile -- + * + * Compile a regular expression into a form suitable for fast + * matching. This procedure retains a small cache of pre-compiled + * regular expressions in the interpreter, in order to avoid + * compilation costs as much as possible. + * + * Results: + * The return value is a pointer to the compiled form of string, + * suitable for passing to Tcl_RegExpExec. This compiled form + * is only valid up until the next call to this procedure, so + * don't keep these around for a long time! If an error occurred + * while compiling the pattern, then NULL is returned and an error + * message is left in interp->result. + * + * Side effects: + * The cache of compiled regexp's in interp will be modified to + * hold information for string, if such information isn't already + * present in the cache. + * + *---------------------------------------------------------------------- + */ + +Tcl_RegExp +Tcl_RegExpCompile(interp, string) + Tcl_Interp *interp; /* For use in error reporting. */ + char *string; /* String for which to produce + * compiled regular expression. */ +{ + register Interp *iPtr = (Interp *) interp; + int i, length; + regexp *result; + + length = strlen(string); + for (i = 0; i < NUM_REGEXPS; i++) { + if ((length == iPtr->patLengths[i]) + && (strcmp(string, iPtr->patterns[i]) == 0)) { + /* + * Move the matched pattern to the first slot in the + * cache and shift the other patterns down one position. + */ + + if (i != 0) { + int j; + char *cachedString; + + cachedString = iPtr->patterns[i]; + result = iPtr->regexps[i]; + for (j = i-1; j >= 0; j--) { + iPtr->patterns[j+1] = iPtr->patterns[j]; + iPtr->patLengths[j+1] = iPtr->patLengths[j]; + iPtr->regexps[j+1] = iPtr->regexps[j]; + } + iPtr->patterns[0] = cachedString; + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + } + return (Tcl_RegExp) iPtr->regexps[0]; + } + } + + /* + * No match in the cache. Compile the string and add it to the + * cache. + */ + + TclRegError((char *) NULL); + result = TclRegComp(string); + if (TclGetRegError() != NULL) { + Tcl_AppendResult(interp, + "couldn't compile regular expression pattern: ", + TclGetRegError(), (char *) NULL); + return NULL; + } + if (iPtr->patterns[NUM_REGEXPS-1] != NULL) { + ckfree(iPtr->patterns[NUM_REGEXPS-1]); + ckfree((char *) iPtr->regexps[NUM_REGEXPS-1]); + } + for (i = NUM_REGEXPS - 2; i >= 0; i--) { + iPtr->patterns[i+1] = iPtr->patterns[i]; + iPtr->patLengths[i+1] = iPtr->patLengths[i]; + iPtr->regexps[i+1] = iPtr->regexps[i]; + } + iPtr->patterns[0] = (char *) ckalloc((unsigned) (length+1)); + strcpy(iPtr->patterns[0], string); + iPtr->patLengths[0] = length; + iPtr->regexps[0] = result; + return (Tcl_RegExp) result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpExec -- + * + * Execute the regular expression matcher using a compiled form + * of a regular expression and save information about any match + * that is found. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if a matching range is + * found and 0 if there is no matching range. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpExec(interp, re, string, start) + Tcl_Interp *interp; /* Interpreter to use for error reporting. */ + Tcl_RegExp re; /* Compiled regular expression; must have + * been returned by previous call to + * Tcl_RegExpCompile. */ + char *string; /* String against which to match re. */ + char *start; /* If string is part of a larger string, + * this identifies beginning of larger + * string, so that "^" won't match. */ +{ + int match; + + regexp *regexpPtr = (regexp *) re; + TclRegError((char *) NULL); + match = TclRegExec(regexpPtr, string, start); + if (TclGetRegError() != NULL) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error while matching regular expression: ", + TclGetRegError(), (char *) NULL); + return -1; + } + return match; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpRange -- + * + * Returns pointers describing the range of a regular expression match, + * or one of the subranges within the match. + * + * Results: + * The variables at *startPtr and *endPtr are modified to hold the + * addresses of the endpoints of the range given by index. If the + * specified range doesn't exist then NULLs are returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_RegExpRange(re, index, startPtr, endPtr) + Tcl_RegExp re; /* Compiled regular expression that has + * been passed to Tcl_RegExpExec. */ + int index; /* 0 means give the range of the entire + * match, > 0 means give the range of + * a matching subrange. Must be no greater + * than NSUBEXP. */ + char **startPtr; /* Store address of first character in + * (sub-) range here. */ + char **endPtr; /* Store address of character just after last + * in (sub-) range here. */ +{ + regexp *regexpPtr = (regexp *) re; + + if (index >= NSUBEXP) { + *startPtr = *endPtr = NULL; + } else { + *startPtr = regexpPtr->startp[index]; + *endPtr = regexpPtr->endp[index]; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RegExpMatch -- + * + * See if a string matches a regular expression. + * + * Results: + * If an error occurs during the matching operation then -1 + * is returned and interp->result contains an error message. + * Otherwise the return value is 1 if "string" matches "pattern" + * and 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_RegExpMatch(interp, string, pattern) + Tcl_Interp *interp; /* Used for error reporting. */ + char *string; /* String. */ + char *pattern; /* Regular expression to match against + * string. */ +{ + Tcl_RegExp re; + + re = Tcl_RegExpCompile(interp, pattern); + if (re == NULL) { + return -1; + } + return Tcl_RegExpExec(interp, re, string, string); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringInit -- + * + * Initializes a dynamic string, discarding any previous contents + * of the string (Tcl_DStringFree should have been called already + * if the dynamic string was previously in use). + * + * Results: + * None. + * + * Side effects: + * The dynamic string is initialized to be empty. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringInit(dsPtr) + register Tcl_DString *dsPtr; /* Pointer to structure for + * dynamic string. */ +{ + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppend -- + * + * Append more characters to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * Length bytes from string (or all of string if length is less + * than zero) are added to the current value of the string. Memory + * gets reallocated if needed to accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppend(dsPtr, string, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. If length is + * -1 then this must be + * null-terminated. */ + int length; /* Number of characters from string + * to append. If < 0, then append all + * of string, up to null at end. */ +{ + int newSize; + char *newString, *dst, *end; + + if (length < 0) { + length = strlen(string); + } + newSize = length + dsPtr->length; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *)newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Copy the new string into the buffer at the end of the old + * one. + */ + + for (dst = dsPtr->string + dsPtr->length, end = string+length; + string < end; string++, dst++) { + *dst = *string; + } + *dst = 0; + dsPtr->length += length; + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringAppendElement -- + * + * Append a list element to the current value of a dynamic string. + * + * Results: + * The return value is a pointer to the dynamic string's new value. + * + * Side effects: + * String is reformatted as a list element and added to the current + * value of the string. Memory gets reallocated if needed to + * accomodate the string's new size. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_DStringAppendElement(dsPtr, string) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + char *string; /* String to append. Must be + * null-terminated. */ +{ + int newSize, flags; + char *dst, *newString; + + newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; + + /* + * Allocate a larger buffer for the string if the current one isn't + * large enough. Allocate extra space in the new buffer so that there + * will be room to grow before we have to allocate again. + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize*2; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + + /* + * Convert the new string to a list element and copy it into the + * buffer at the end, with a space, if needed. + */ + + dst = dsPtr->string + dsPtr->length; + if (TclNeedSpace(dsPtr->string, dst)) { + *dst = ' '; + dst++; + dsPtr->length++; + } + dsPtr->length += Tcl_ConvertElement(string, dst, flags); + return dsPtr->string; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringSetLength -- + * + * Change the length of a dynamic string. This can cause the + * string to either grow or shrink, depending on the value of + * length. + * + * Results: + * None. + * + * Side effects: + * The length of dsPtr is changed to length and a null byte is + * stored at that position in the string. If length is larger + * than the space allocated for dsPtr, then a panic occurs. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringSetLength(dsPtr, length) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ + int length; /* New length for dynamic string. */ +{ + if (length < 0) { + length = 0; + } + if (length >= dsPtr->spaceAvl) { + char *newString; + + dsPtr->spaceAvl = length+1; + newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); + + /* + * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string + * to a larger buffer, since there may be embedded NULLs in the + * string in some cases. + */ + + memcpy((VOID *) newString, (VOID *) dsPtr->string, + (size_t) dsPtr->length); + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = newString; + } + dsPtr->length = length; + dsPtr->string[length] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringFree -- + * + * Frees up any memory allocated for the dynamic string and + * reinitializes the string to an empty state. + * + * Results: + * None. + * + * Side effects: + * The previous contents of the dynamic string are lost, and + * the new value is an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringFree(dsPtr) + register Tcl_DString *dsPtr; /* Structure describing dynamic + * string. */ +{ + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringResult -- + * + * This procedure moves the value of a dynamic string into an + * interpreter as its result. The string itself is reinitialized + * to an empty string. + * + * Results: + * None. + * + * Side effects: + * The string is "moved" to interp's result, and any existing + * result for interp is freed up. DsPtr is reinitialized to + * an empty string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Tcl_ResetResult(interp); + if (dsPtr->string != dsPtr->staticSpace) { + interp->result = dsPtr->string; + interp->freeProc = TCL_DYNAMIC; + } else if (dsPtr->length < TCL_RESULT_SIZE) { + interp->result = ((Interp *) interp)->resultSpace; + strcpy(interp->result, dsPtr->string); + } else { + Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); + } + dsPtr->string = dsPtr->staticSpace; + dsPtr->length = 0; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + dsPtr->staticSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringGetResult -- + * + * This procedure moves the result of an interpreter into a + * dynamic string. + * + * Results: + * None. + * + * Side effects: + * The interpreter's result is cleared, and the previous contents + * of dsPtr are freed. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringGetResult(interp, dsPtr) + Tcl_Interp *interp; /* Interpreter whose result is to be + * reset. */ + Tcl_DString *dsPtr; /* Dynamic string that is to become + * the result of interp. */ +{ + Interp *iPtr = (Interp *) interp; + if (dsPtr->string != dsPtr->staticSpace) { + ckfree(dsPtr->string); + } + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if ((iPtr->freeProc == TCL_DYNAMIC) + || (iPtr->freeProc == (Tcl_FreeProc *) free)) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); + strcpy(dsPtr->string, iPtr->result); + (*iPtr->freeProc)(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); + dsPtr->spaceAvl = dsPtr->length + 1; + } + strcpy(dsPtr->string, iPtr->result); + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringStartSublist -- + * + * This procedure adds the necessary information to a dynamic + * string (e.g. " {" to start a sublist. Future element + * appends will be in the sublist rather than the main list. + * + * Results: + * None. + * + * Side effects: + * Characters get added to the dynamic string. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringStartSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { + Tcl_DStringAppend(dsPtr, " {", -1); + } else { + Tcl_DStringAppend(dsPtr, "{", -1); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DStringEndSublist -- + * + * This procedure adds the necessary characters to a dynamic + * string to end a sublist (e.g. "}"). Future element appends + * will be in the enclosing (sub)list rather than the current + * sublist. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_DStringEndSublist(dsPtr) + Tcl_DString *dsPtr; /* Dynamic string. */ +{ + Tcl_DStringAppend(dsPtr, "}", -1); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_PrintDouble -- + * + * Given a floating-point value, this procedure converts it to + * an ASCII string using. + * + * Results: + * The ASCII equivalent of "value" is written at "dst". It is + * written using the current precision, and it is guaranteed to + * contain a decimal point or exponent, so that it looks like + * a floating-point value and not an integer. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_PrintDouble(interp, value, dst) + Tcl_Interp *interp; /* Interpreter whose tcl_precision + * variable controls printing. */ + double value; /* Value to print as string. */ + char *dst; /* Where to store converted value; + * must have at least TCL_DOUBLE_SPACE + * characters. */ +{ + register char *p; + sprintf(dst, ((Interp *) interp)->pdFormat, value); + + /* + * If the ASCII result looks like an integer, add ".0" so that it + * doesn't look like an integer anymore. This prevents floating-point + * values from being converted to integers unintentionally. + */ + + for (p = dst; *p != 0; p++) { + if ((*p == '.') || (isalpha(UCHAR(*p)))) { + return; + } + } + p[0] = '.'; + p[1] = '0'; + p[2] = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrecTraceProc -- + * + * This procedure is invoked whenever the variable "tcl_precision" + * is written. + * + * Results: + * Returns NULL if all went well, or an error message if the + * new value for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this procedure + * undoes the effect of the variable modification. Otherwise + * it modifies the format string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +char * +TclPrecTraceProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Name of variable. */ + char *name2; /* Second part of variable name. */ + int flags; /* Information about what happened. */ +{ + register Interp *iPtr = (Interp *) interp; + char *value, *end; + int prec; + + /* + * If the variable is unset, then recreate the trace and restore + * the default value of the format string. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + TclPrecTraceProc, clientData); + } + strcpy(iPtr->pdFormat, DEFAULT_PD_FORMAT); + iPtr->pdPrec = DEFAULT_PD_PREC; + return (char *) NULL; + } + + value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL) { + value = ""; + } + prec = strtoul(value, &end, 10); + if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || + (end == value) || (*end != 0)) { + char oldValue[10]; + + sprintf(oldValue, "%d", iPtr->pdPrec); + Tcl_SetVar2(interp, name1, name2, oldValue, flags & TCL_GLOBAL_ONLY); + return "improper value for precision"; + } + sprintf(iPtr->pdFormat, "%%.%dg", prec); + iPtr->pdPrec = prec; + return (char *) NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclNeedSpace -- + * + * This procedure checks to see whether it is appropriate to + * add a space before appending a new list element to an + * existing string. + * + * Results: + * The return value is 1 if a space is appropriate, 0 otherwise. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclNeedSpace(start, end) + char *start; /* First character in string. */ + char *end; /* End of string (place where space will + * be added, if appropriate). */ +{ + /* + * A space is needed unless either + * (a) we're at the start of the string, or + * (b) the trailing characters of the string consist of one or more + * open curly braces preceded by a space or extending back to + * the beginning of the string. + * (c) the trailing characters of the string consist of a space + * preceded by a character other than backslash. + */ + + if (end == start) { + return 0; + } + end--; + if (*end != '{') { + if (isspace(UCHAR(*end)) && ((end == start) || (end[-1] != '\\'))) { + return 0; + } + return 1; + } + do { + if (end == start) { + return 0; + } + end--; + } while (*end == '{'); + if (isspace(UCHAR(*end))) { + return 0; + } + return 1; +} |
