Parent Directory
| 
Revision Log
| 
Patch
| revision 44 by dashley, Fri Oct 14 02:09:58 2016 UTC | revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC | |
|---|---|---|
| # | Line 1 | Line 1 |
| /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclutil.c,v 1.1.1.1 2001/06/13 04:47:21 dtashley Exp $ */ | ||
| /* | ||
| * 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-1998 Sun Microsystems, Inc. | ||
| * | ||
| * See the file "license.terms" for information on usage and redistribution | ||
| * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | ||
| * | ||
| * RCS: @(#) $Id: tclutil.c,v 1.1.1.1 2001/06/13 04:47:21 dtashley Exp $ | ||
| */ | ||
| #include "tclInt.h" | ||
| #include "tclPort.h" | ||
| /* | ||
| * The following variable holds the full path name of the binary | ||
| * from which this application was executed, or NULL if it isn't | ||
| * know. The value of the variable is set by the procedure | ||
| * Tcl_FindExecutable. The storage space is dynamically allocated. | ||
| */ | ||
| char *tclExecutableName = NULL; | ||
| char *tclNativeExecutableName = NULL; | ||
| /* | ||
| * 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 | ||
| /* | ||
| * The following values determine the precision used when converting | ||
| * floating-point values to strings. This information is linked to all | ||
| * of the tcl_precision variables in all interpreters via the procedure | ||
| * TclPrecTraceProc. | ||
| */ | ||
| static char precisionString[10] = "12"; | ||
| /* The string value of all the tcl_precision | ||
| * variables. */ | ||
| static char precisionFormat[10] = "%.12g"; | ||
| /* The format string actually used in calls | ||
| * to sprintf. */ | ||
| TCL_DECLARE_MUTEX(precisionMutex) | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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; | ||
| * the interp's 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 just after the last character in the | ||
| * list (i.e., at the character at list+listLength). 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 point | ||
| * just after the last character in the list. Note: this procedure does | ||
| * NOT collapse backslash sequences. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, | ||
| bracePtr) | ||
| Tcl_Interp *interp; /* Interpreter to use for error reporting. | ||
| * If NULL, then no error message is left | ||
| * after errors. */ | ||
| CONST char *list; /* Points to the first byte of a string | ||
| * containing a Tcl list with zero or more | ||
| * elements (possibly in braces). */ | ||
| int listLength; /* Number of bytes in the list's string. */ | ||
| CONST char **elementPtr; /* Where to put address of first significant | ||
| * character in first element of list. */ | ||
| CONST char **nextPtr; /* Fill in with location of character just | ||
| * after all white space following end of | ||
| * argument (next arg 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. */ | ||
| { | ||
| CONST char *p = list; | ||
| CONST char *elemStart; /* Points to first byte of first element. */ | ||
| CONST char *limit; /* Points just after list's last byte. */ | ||
| int openBraces = 0; /* Brace nesting level during parse. */ | ||
| int inQuotes = 0; | ||
| int size = 0; /* lint. */ | ||
| int numChars; | ||
| CONST char *p2; | ||
| /* | ||
| * Skim off leading white space and check for an opening brace or | ||
| * quote. We treat embedded NULLs in the list as bytes belonging to | ||
| * a list element. | ||
| */ | ||
| limit = (list + listLength); | ||
| while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ | ||
| p++; | ||
| } | ||
| if (p == limit) { /* no element found */ | ||
| elemStart = limit; | ||
| goto done; | ||
| } | ||
| if (*p == '{') { | ||
| openBraces = 1; | ||
| p++; | ||
| } else if (*p == '"') { | ||
| inQuotes = 1; | ||
| p++; | ||
| } | ||
| elemStart = p; | ||
| if (bracePtr != 0) { | ||
| *bracePtr = openBraces; | ||
| } | ||
| /* | ||
| * Find element's end (a space, close brace, or the end of the string). | ||
| */ | ||
| while (p < limit) { | ||
| 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) { | ||
| openBraces--; | ||
| } else if (openBraces == 1) { | ||
| size = (p - elemStart); | ||
| p++; | ||
| if ((p >= limit) | ||
| || isspace(UCHAR(*p))) { /* INTL: ISO space. */ | ||
| goto done; | ||
| } | ||
| /* | ||
| * Garbage after the closing brace; return an error. | ||
| */ | ||
| if (interp != NULL) { | ||
| char buf[100]; | ||
| p2 = p; | ||
| while ((p2 < limit) | ||
| && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ | ||
| && (p2 < p+20)) { | ||
| p2++; | ||
| } | ||
| sprintf(buf, | ||
| "list element in braces followed by \"%.*s\" instead of space", | ||
| (int) (p2-p), p); | ||
| Tcl_SetResult(interp, buf, TCL_VOLATILE); | ||
| } | ||
| return TCL_ERROR; | ||
| } | ||
| break; | ||
| /* | ||
| * Backslash: skip over everything up to the end of the | ||
| * backslash sequence. | ||
| */ | ||
| case '\\': { | ||
| Tcl_UtfBackslash(p, &numChars, NULL); | ||
| p += (numChars - 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 - elemStart); | ||
| goto done; | ||
| } | ||
| break; | ||
| /* | ||
| * Double-quote: if element is in quotes then terminate it. | ||
| */ | ||
| case '"': | ||
| if (inQuotes) { | ||
| size = (p - elemStart); | ||
| p++; | ||
| if ((p >= limit) | ||
| || isspace(UCHAR(*p))) { /* INTL: ISO space */ | ||
| goto done; | ||
| } | ||
| /* | ||
| * Garbage after the closing quote; return an error. | ||
| */ | ||
| if (interp != NULL) { | ||
| char buf[100]; | ||
| p2 = p; | ||
| while ((p2 < limit) | ||
| && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ | ||
| && (p2 < p+20)) { | ||
| p2++; | ||
| } | ||
| sprintf(buf, | ||
| "list element in quotes followed by \"%.*s\" %s", | ||
| (int) (p2-p), p, "instead of space"); | ||
| Tcl_SetResult(interp, buf, TCL_VOLATILE); | ||
| } | ||
| return TCL_ERROR; | ||
| } | ||
| break; | ||
| } | ||
| p++; | ||
| } | ||
| /* | ||
| * End of list: terminate element. | ||
| */ | ||
| if (p == limit) { | ||
| 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 - elemStart); | ||
| } | ||
| done: | ||
| while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ | ||
| p++; | ||
| } | ||
| *elementPtr = elemStart; | ||
| *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 characters 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. | ||
| * Returns the number of characters that got copied. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclCopyAndCollapse(count, src, dst) | ||
| int count; /* Number of characters to copy from src. */ | ||
| CONST char *src; /* Copy from here... */ | ||
| char *dst; /* ... to here. */ | ||
| { | ||
| register char c; | ||
| int numRead; | ||
| int newCount = 0; | ||
| int backslashCount; | ||
| for (c = *src; count > 0; src++, c = *src, count--) { | ||
| if (c == '\\') { | ||
| backslashCount = Tcl_UtfBackslash(src, &numRead, dst); | ||
| dst += backslashCount; | ||
| newCount += backslashCount; | ||
| src += numRead-1; | ||
| count -= numRead-1; | ||
| } else { | ||
| *dst = c; | ||
| dst++; | ||
| newCount++; | ||
| } | ||
| } | ||
| *dst = 0; | ||
| return newCount; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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; the interp's 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, no error message is left. */ | ||
| CONST 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; | ||
| CONST char *l; | ||
| char *p; | ||
| int length, size, i, result, elSize, brace; | ||
| CONST 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, l = list; *l != 0; l++) { | ||
| if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ | ||
| size++; | ||
| } | ||
| } | ||
| size++; /* Leave space for final NULL pointer. */ | ||
| argv = (char **) ckalloc((unsigned) | ||
| ((size * sizeof(char *)) + (l - list) + 1)); | ||
| length = strlen(list); | ||
| for (i = 0, p = ((char *) argv) + size*sizeof(char *); | ||
| *list != 0; i++) { | ||
| CONST char *prevList = list; | ||
| result = TclFindElement(interp, list, length, &element, | ||
| &list, &elSize, &brace); | ||
| length -= (list - prevList); | ||
| 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) { | ||
| memcpy((VOID *) p, (VOID *) 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) | ||
| register CONST char *string; /* String to convert to list element. */ | ||
| register int *flagPtr; /* Where to store information to guide | ||
| * Tcl_ConvertCountedElement. */ | ||
| { | ||
| return Tcl_ScanCountedElement(string, -1, flagPtr); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ScanCountedElement -- | ||
| * | ||
| * This procedure is a companion procedure to | ||
| * Tcl_ConvertCountedElement. 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. | ||
| * If length is -1, then the string is scanned up to the first | ||
| * null byte. | ||
| * | ||
| * Results: | ||
| * The return value is an overestimate of the number of characters | ||
| * that will be needed by Tcl_ConvertCountedElement to produce a | ||
| * valid list element from string. The word at *flagPtr is | ||
| * filled in with a value needed by Tcl_ConvertCountedElement | ||
| * when doing the actual conversion. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_ScanCountedElement(string, length, flagPtr) | ||
| CONST char *string; /* String to convert to Tcl list element. */ | ||
| int length; /* Number of bytes in string, or -1. */ | ||
| int *flagPtr; /* Where to store information to guide | ||
| * Tcl_ConvertElement. */ | ||
| { | ||
| int flags, nestingLevel; | ||
| register CONST char *p, *lastChar; | ||
| /* | ||
| * 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 any 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. | ||
| * | ||
| * Note: list elements produced by this procedure and | ||
| * Tcl_ConvertCountedElement must have the property that they can be | ||
| * enclosing in curly braces to make sub-lists. This means, for | ||
| * example, that we must not leave unmatched curly braces in the | ||
| * resulting list element. This property is necessary in order for | ||
| * procedures like Tcl_DStringStartSublist to work. | ||
| */ | ||
| nestingLevel = 0; | ||
| flags = 0; | ||
| if (string == NULL) { | ||
| string = ""; | ||
| } | ||
| if (length == -1) { | ||
| length = strlen(string); | ||
| } | ||
| lastChar = string + length; | ||
| p = string; | ||
| if ((p == lastChar) || (*p == '{') || (*p == '"')) { | ||
| flags |= USE_BRACES; | ||
| } | ||
| for ( ; p < lastChar; 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 == lastChar) || (p[1] == '\n')) { | ||
| flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; | ||
| } else { | ||
| int size; | ||
| Tcl_UtfBackslash(p, &size, NULL); | ||
| 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 CONST char *src; /* Source information for list element. */ | ||
| register char *dst; /* Place to put list-ified element. */ | ||
| register int flags; /* Flags produced by Tcl_ScanElement. */ | ||
| { | ||
| return Tcl_ConvertCountedElement(src, -1, dst, flags); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ConvertCountedElement -- | ||
| * | ||
| * This is a companion procedure to Tcl_ScanCountedElement. Given | ||
| * the information produced by Tcl_ScanCountedElement, 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_ConvertCountedElement(src, length, dst, flags) | ||
| register CONST char *src; /* Source information for list element. */ | ||
| int length; /* Number of bytes in src, or -1. */ | ||
| char *dst; /* Place to put list-ified element. */ | ||
| int flags; /* Flags produced by Tcl_ScanElement. */ | ||
| { | ||
| register char *p = dst; | ||
| register CONST char *lastChar; | ||
| /* | ||
| * See the comment block at the beginning of the Tcl_ScanElement | ||
| * code for details of how this works. | ||
| */ | ||
| if (src && length == -1) { | ||
| length = strlen(src); | ||
| } | ||
| if ((src == NULL) || (length == 0)) { | ||
| p[0] = '{'; | ||
| p[1] = '}'; | ||
| p[2] = 0; | ||
| return 2; | ||
| } | ||
| lastChar = src + length; | ||
| if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { | ||
| *p = '{'; | ||
| p++; | ||
| for ( ; src != lastChar; 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 != lastChar; 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; | ||
| 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_Backslash -- | ||
| * | ||
| * Figure out how to handle a backslash sequence. | ||
| * | ||
| * Results: | ||
| * The return value is the character that should be substituted | ||
| * in place of the backslash sequence that starts at src. If | ||
| * readPtr isn't NULL then it is filled in with a count of the | ||
| * number of characters in the backslash sequence. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| char | ||
| Tcl_Backslash(src, readPtr) | ||
| CONST char *src; /* Points to the backslash character of | ||
| * a backslash sequence. */ | ||
| int *readPtr; /* Fill in with number of characters read | ||
| * from src, unless NULL. */ | ||
| { | ||
| char buf[TCL_UTF_MAX]; | ||
| Tcl_UniChar ch; | ||
| Tcl_UtfBackslash(src, readPtr, buf); | ||
| Tcl_UtfToUniChar(buf, &ch); | ||
| return (char) ch; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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; | ||
| 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))) { /* INTL: ISO space. */ | ||
| element++; | ||
| } | ||
| for (length = strlen(element); | ||
| (length > 0) | ||
| && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ | ||
| && ((length < 2) || (element[length-2] != '\\')); | ||
| length--) { | ||
| /* Null loop body. */ | ||
| } | ||
| if (length == 0) { | ||
| continue; | ||
| } | ||
| memcpy((VOID *) p, (VOID *) element, (size_t) length); | ||
| p += length; | ||
| *p = ' '; | ||
| p++; | ||
| } | ||
| if (p != result) { | ||
| p[-1] = 0; | ||
| } else { | ||
| *p = 0; | ||
| } | ||
| return result; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_ConcatObj -- | ||
| * | ||
| * Concatenate the strings from a set of objects into a single string | ||
| * object with spaces between the original strings. | ||
| * | ||
| * Results: | ||
| * The return value is a new string object containing a concatenation | ||
| * of the strings in objv. Its ref count is zero. | ||
| * | ||
| * Side effects: | ||
| * A new object is created. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| Tcl_Obj * | ||
| Tcl_ConcatObj(objc, objv) | ||
| int objc; /* Number of objects to concatenate. */ | ||
| Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ | ||
| { | ||
| int allocSize, finalSize, length, elemLength, i; | ||
| char *p; | ||
| char *element; | ||
| char *concatStr; | ||
| Tcl_Obj *objPtr; | ||
| /* | ||
| * Check first to see if all the items are of list type. If so, | ||
| * we will concat them together as lists, and return a list object. | ||
| * This is only valid when the lists have no current string | ||
| * representation, since we don't know what the original type was. | ||
| * An original string rep may have lost some whitespace info when | ||
| * converted which could be important. | ||
| */ | ||
| for (i = 0; i < objc; i++) { | ||
| objPtr = objv[i]; | ||
| if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { | ||
| break; | ||
| } | ||
| } | ||
| if (i == objc) { | ||
| Tcl_Obj **listv; | ||
| int listc; | ||
| objPtr = Tcl_NewListObj(0, NULL); | ||
| for (i = 0; i < objc; i++) { | ||
| /* | ||
| * Tcl_ListObjAppendList could be used here, but this saves | ||
| * us a bit of type checking (since we've already done it) | ||
| * Use of INT_MAX tells us to always put the new stuff on | ||
| * the end. It will be set right in Tcl_ListObjReplace. | ||
| */ | ||
| Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); | ||
| Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); | ||
| } | ||
| return objPtr; | ||
| } | ||
| allocSize = 0; | ||
| for (i = 0; i < objc; i++) { | ||
| objPtr = objv[i]; | ||
| element = Tcl_GetStringFromObj(objPtr, &length); | ||
| if ((element != NULL) && (length > 0)) { | ||
| allocSize += (length + 1); | ||
| } | ||
| } | ||
| if (allocSize == 0) { | ||
| allocSize = 1; /* enough for the NULL byte at end */ | ||
| } | ||
| /* | ||
| * Allocate storage for the concatenated result. Note that allocSize | ||
| * is one more than the total number of characters, and so includes | ||
| * room for the terminating NULL byte. | ||
| */ | ||
| concatStr = (char *) ckalloc((unsigned) allocSize); | ||
| /* | ||
| * Now concatenate the elements. Clip white space off the front and back | ||
| * to generate a neater result, and ignore any empty elements. Also put | ||
| * a null byte at the end. | ||
| */ | ||
| finalSize = 0; | ||
| if (objc == 0) { | ||
| *concatStr = '\0'; | ||
| } else { | ||
| p = concatStr; | ||
| for (i = 0; i < objc; i++) { | ||
| objPtr = objv[i]; | ||
| element = Tcl_GetStringFromObj(objPtr, &elemLength); | ||
| while ((elemLength > 0) | ||
| && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */ | ||
| element++; | ||
| elemLength--; | ||
| } | ||
| /* | ||
| * Trim trailing white space. But, be careful not to trim | ||
| * a space character if it is preceded by a backslash: in | ||
| * this case it could be significant. | ||
| */ | ||
| while ((elemLength > 0) | ||
| && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */ | ||
| && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { | ||
| elemLength--; | ||
| } | ||
| if (elemLength == 0) { | ||
| continue; /* nothing left of this element */ | ||
| } | ||
| memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); | ||
| p += elemLength; | ||
| *p = ' '; | ||
| p++; | ||
| finalSize += (elemLength + 1); | ||
| } | ||
| if (p != concatStr) { | ||
| p[-1] = 0; | ||
| finalSize -= 1; /* we overwrote the final ' ' */ | ||
| } else { | ||
| *p = 0; | ||
| } | ||
| } | ||
| TclNewObj(objPtr); | ||
| objPtr->bytes = concatStr; | ||
| objPtr->length = finalSize; | ||
| return objPtr; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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) | ||
| CONST char *string; /* String. */ | ||
| CONST char *pattern; /* Pattern, which may contain special | ||
| * characters. */ | ||
| { | ||
| int p, s; | ||
| CONST char *pstart = pattern; | ||
| while (1) { | ||
| p = *pattern; | ||
| s = *string; | ||
| /* | ||
| * 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 (p == '\0') { | ||
| if (s == '\0') { | ||
| return 1; | ||
| } else { | ||
| return 0; | ||
| } | ||
| } | ||
| if ((s == '\0') && (p != '*')) { | ||
| 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 (p == '*') { | ||
| pattern++; | ||
| if (*pattern == '\0') { | ||
| return 1; | ||
| } | ||
| while (1) { | ||
| if (Tcl_StringMatch(string, pattern)) { | ||
| return 1; | ||
| } | ||
| if (*string == '\0') { | ||
| return 0; | ||
| } | ||
| string++; | ||
| } | ||
| } | ||
| /* Check for a "?" as the next pattern character. It matches | ||
| * any single character. | ||
| */ | ||
| if (p == '?') { | ||
| Tcl_UniChar ch; | ||
| pattern++; | ||
| string += Tcl_UtfToUniChar(string, &ch); | ||
| continue; | ||
| } | ||
| /* 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 (p == '[') { | ||
| Tcl_UniChar ch, startChar, endChar; | ||
| pattern++; | ||
| string += Tcl_UtfToUniChar(string, &ch); | ||
| while (1) { | ||
| if ((*pattern == ']') || (*pattern == '\0')) { | ||
| return 0; | ||
| } | ||
| pattern += Tcl_UtfToUniChar(pattern, &startChar); | ||
| if (*pattern == '-') { | ||
| pattern++; | ||
| if (*pattern == '\0') { | ||
| return 0; | ||
| } | ||
| pattern += Tcl_UtfToUniChar(pattern, &endChar); | ||
| if (((startChar <= ch) && (ch <= endChar)) | ||
| || ((endChar <= ch) && (ch <= startChar))) { | ||
| /* | ||
| * Matches ranges of form [a-z] or [z-a]. | ||
| */ | ||
| break; | ||
| } | ||
| } else if (startChar == ch) { | ||
| break; | ||
| } | ||
| } | ||
| while (*pattern != ']') { | ||
| if (*pattern == '\0') { | ||
| pattern = Tcl_UtfPrev(pattern, pstart); | ||
| break; | ||
| } | ||
| pattern++; | ||
| } | ||
| pattern++; | ||
| continue; | ||
| } | ||
| /* If the next pattern character is '\', just strip off the '\' | ||
| * so we do exact matching on the character that follows. | ||
| */ | ||
| if (p == '\\') { | ||
| pattern++; | ||
| p = *pattern; | ||
| if (p == '\0') { | ||
| return 0; | ||
| } | ||
| } | ||
| /* There's no special character. Just make sure that the next | ||
| * bytes of each string match. | ||
| */ | ||
| if (s != p) { | ||
| return 0; | ||
| } | ||
| pattern++; | ||
| string++; | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_StringCaseMatch -- | ||
| * | ||
| * See if a particular string matches a particular pattern. | ||
| * Allows case insensitivity. | ||
| * | ||
| * 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_StringCaseMatch(string, pattern, nocase) | ||
| CONST char *string; /* String. */ | ||
| CONST char *pattern; /* Pattern, which may contain special | ||
| * characters. */ | ||
| int nocase; /* 0 for case sensitive, 1 for insensitive */ | ||
| { | ||
| int p, s; | ||
| CONST char *pstart = pattern; | ||
| Tcl_UniChar ch1, ch2; | ||
| while (1) { | ||
| p = *pattern; | ||
| s = *string; | ||
| /* | ||
| * 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 (p == '\0') { | ||
| return (s == '\0'); | ||
| } | ||
| if ((s == '\0') && (p != '*')) { | ||
| 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 (p == '*') { | ||
| pattern++; | ||
| if (*pattern == '\0') { | ||
| return 1; | ||
| } | ||
| while (1) { | ||
| if (Tcl_StringCaseMatch(string, pattern, nocase)) { | ||
| return 1; | ||
| } | ||
| if (*string == '\0') { | ||
| return 0; | ||
| } | ||
| string++; | ||
| } | ||
| } | ||
| /* Check for a "?" as the next pattern character. It matches | ||
| * any single character. | ||
| */ | ||
| if (p == '?') { | ||
| pattern++; | ||
| string += Tcl_UtfToUniChar(string, &ch1); | ||
| continue; | ||
| } | ||
| /* 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 (p == '[') { | ||
| Tcl_UniChar startChar, endChar; | ||
| pattern++; | ||
| string += Tcl_UtfToUniChar(string, &ch1); | ||
| if (nocase) { | ||
| ch1 = Tcl_UniCharToLower(ch1); | ||
| } | ||
| while (1) { | ||
| if ((*pattern == ']') || (*pattern == '\0')) { | ||
| return 0; | ||
| } | ||
| pattern += Tcl_UtfToUniChar(pattern, &startChar); | ||
| if (nocase) { | ||
| startChar = Tcl_UniCharToLower(startChar); | ||
| } | ||
| if (*pattern == '-') { | ||
| pattern++; | ||
| if (*pattern == '\0') { | ||
| return 0; | ||
| } | ||
| pattern += Tcl_UtfToUniChar(pattern, &endChar); | ||
| if (nocase) { | ||
| endChar = Tcl_UniCharToLower(endChar); | ||
| } | ||
| if (((startChar <= ch1) && (ch1 <= endChar)) | ||
| || ((endChar <= ch1) && (ch1 <= startChar))) { | ||
| /* | ||
| * Matches ranges of form [a-z] or [z-a]. | ||
| */ | ||
| break; | ||
| } | ||
| } else if (startChar == ch1) { | ||
| break; | ||
| } | ||
| } | ||
| while (*pattern != ']') { | ||
| if (*pattern == '\0') { | ||
| pattern = Tcl_UtfPrev(pattern, pstart); | ||
| break; | ||
| } | ||
| pattern++; | ||
| } | ||
| pattern++; | ||
| continue; | ||
| } | ||
| /* If the next pattern character is '\', just strip off the '\' | ||
| * so we do exact matching on the character that follows. | ||
| */ | ||
| if (p == '\\') { | ||
| pattern++; | ||
| p = *pattern; | ||
| if (p == '\0') { | ||
| return 0; | ||
| } | ||
| } | ||
| /* There's no special character. Just make sure that the next | ||
| * bytes of each string match. | ||
| */ | ||
| string += Tcl_UtfToUniChar(string, &ch1); | ||
| pattern += Tcl_UtfToUniChar(pattern, &ch2); | ||
| if (nocase) { | ||
| if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { | ||
| return 0; | ||
| } | ||
| } else if (ch1 != ch2) { | ||
| return 0; | ||
| } | ||
| } | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * 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) | ||
| 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) | ||
| Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | ||
| CONST 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 *dst; | ||
| CONST char *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; | ||
| if (dsPtr->string == dsPtr->staticSpace) { | ||
| char *newString; | ||
| newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | ||
| memcpy((VOID *) newString, (VOID *) dsPtr->string, | ||
| (size_t) dsPtr->length); | ||
| dsPtr->string = newString; | ||
| } else { | ||
| dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | ||
| (size_t) dsPtr->spaceAvl); | ||
| } | ||
| } | ||
| /* | ||
| * 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) | ||
| Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | ||
| CONST char *string; /* String to append. Must be | ||
| * null-terminated. */ | ||
| { | ||
| int newSize, flags; | ||
| char *dst; | ||
| 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; | ||
| if (dsPtr->string == dsPtr->staticSpace) { | ||
| char *newString; | ||
| newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | ||
| memcpy((VOID *) newString, (VOID *) dsPtr->string, | ||
| (size_t) dsPtr->length); | ||
| dsPtr->string = newString; | ||
| } else { | ||
| dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | ||
| (size_t) dsPtr->spaceAvl); | ||
| } | ||
| } | ||
| /* | ||
| * 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) | ||
| Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | ||
| int length; /* New length for dynamic string. */ | ||
| { | ||
| int newsize; | ||
| if (length < 0) { | ||
| length = 0; | ||
| } | ||
| if (length >= dsPtr->spaceAvl) { | ||
| /* | ||
| * There are two interesting cases here. In the first case, the user | ||
| * may be trying to allocate a large buffer of a specific size. It | ||
| * would be wasteful to overallocate that buffer, so we just allocate | ||
| * enough for the requested size plus the trailing null byte. In the | ||
| * second case, we are growing the buffer incrementally, so we need | ||
| * behavior similar to Tcl_DStringAppend. The requested length will | ||
| * usually be a small delta above the current spaceAvl, so we'll end up | ||
| * doubling the old size. This won't grow the buffer quite as quickly, | ||
| * but it should be close enough. | ||
| */ | ||
| newsize = dsPtr->spaceAvl * 2; | ||
| if (length < newsize) { | ||
| dsPtr->spaceAvl = newsize; | ||
| } else { | ||
| dsPtr->spaceAvl = length + 1; | ||
| } | ||
| if (dsPtr->string == dsPtr->staticSpace) { | ||
| char *newString; | ||
| newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | ||
| memcpy((VOID *) newString, (VOID *) dsPtr->string, | ||
| (size_t) dsPtr->length); | ||
| dsPtr->string = newString; | ||
| } else { | ||
| dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | ||
| (size_t) dsPtr->spaceAvl); | ||
| } | ||
| } | ||
| 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) | ||
| 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 string result. Afterwards, the dynamic string | ||
| * is reset to an empty string. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The string is "moved" to interp's result, and any existing | ||
| * string result for interp is freed. 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 an interpreter's result into a dynamic string. | ||
| * | ||
| * Results: | ||
| * None. | ||
| * | ||
| * Side effects: | ||
| * The interpreter's string result is cleared, and the previous | ||
| * contents of dsPtr are freed. | ||
| * | ||
| * If the string result is empty, the object result is moved to the | ||
| * string result, then the object result is reset. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| 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); | ||
| } | ||
| /* | ||
| * If the string result is empty, move the object result to the | ||
| * string result, then reset the object result. | ||
| */ | ||
| if (*(iPtr->result) == 0) { | ||
| Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | ||
| TCL_VOLATILE); | ||
| } | ||
| 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 used to be used to control | ||
| * printing. It's ignored now. */ | ||
| double value; /* Value to print as string. */ | ||
| char *dst; /* Where to store converted value; | ||
| * must have at least TCL_DOUBLE_SPACE | ||
| * characters. */ | ||
| { | ||
| char *p, c; | ||
| Tcl_UniChar ch; | ||
| Tcl_MutexLock(&precisionMutex); | ||
| sprintf(dst, precisionFormat, value); | ||
| Tcl_MutexUnlock(&precisionMutex); | ||
| /* | ||
| * 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 += Tcl_UtfToUniChar(p, &ch); | ||
| c = UCHAR(ch); | ||
| if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ | ||
| 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. */ | ||
| { | ||
| char *value, *end; | ||
| int prec; | ||
| /* | ||
| * If the variable is unset, then recreate the trace. | ||
| */ | ||
| if (flags & TCL_TRACE_UNSETS) { | ||
| if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { | ||
| Tcl_TraceVar2(interp, name1, name2, | ||
| TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES | ||
| |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); | ||
| } | ||
| return (char *) NULL; | ||
| } | ||
| /* | ||
| * When the variable is read, reset its value from our shared | ||
| * value. This is needed in case the variable was modified in | ||
| * some other interpreter so that this interpreter's value is | ||
| * out of date. | ||
| */ | ||
| Tcl_MutexLock(&precisionMutex); | ||
| if (flags & TCL_TRACE_READS) { | ||
| Tcl_SetVar2(interp, name1, name2, precisionString, | ||
| flags & TCL_GLOBAL_ONLY); | ||
| Tcl_MutexUnlock(&precisionMutex); | ||
| return (char *) NULL; | ||
| } | ||
| /* | ||
| * The variable is being written. Check the new value and disallow | ||
| * it if it isn't reasonable or if this is a safe interpreter (we | ||
| * don't want safe interpreters messing up the precision of other | ||
| * interpreters). | ||
| */ | ||
| if (Tcl_IsSafe(interp)) { | ||
| Tcl_SetVar2(interp, name1, name2, precisionString, | ||
| flags & TCL_GLOBAL_ONLY); | ||
| Tcl_MutexUnlock(&precisionMutex); | ||
| return "can't modify precision from a safe interpreter"; | ||
| } | ||
| 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)) { | ||
| Tcl_SetVar2(interp, name1, name2, precisionString, | ||
| flags & TCL_GLOBAL_ONLY); | ||
| Tcl_MutexUnlock(&precisionMutex); | ||
| return "improper value for precision"; | ||
| } | ||
| TclFormatInt(precisionString, prec); | ||
| sprintf(precisionFormat, "%%.%dg", prec); | ||
| Tcl_MutexUnlock(&precisionMutex); | ||
| 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)) /* INTL: ISO space. */ | ||
| && ((end == start) || (end[-1] != '\\'))) { | ||
| return 0; | ||
| } | ||
| return 1; | ||
| } | ||
| do { | ||
| if (end == start) { | ||
| return 0; | ||
| } | ||
| end--; | ||
| } while (*end == '{'); | ||
| if (isspace(UCHAR(*end))) { /* INTL: ISO space. */ | ||
| return 0; | ||
| } | ||
| return 1; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclFormatInt -- | ||
| * | ||
| * This procedure formats an integer into a sequence of decimal digit | ||
| * characters in a buffer. If the integer is negative, a minus sign is | ||
| * inserted at the start of the buffer. A null character is inserted at | ||
| * the end of the formatted characters. It is the caller's | ||
| * responsibility to ensure that enough storage is available. This | ||
| * procedure has the effect of sprintf(buffer, "%d", n) but is faster. | ||
| * | ||
| * Results: | ||
| * An integer representing the number of characters formatted, not | ||
| * including the terminating \0. | ||
| * | ||
| * Side effects: | ||
| * The formatted characters are written into the storage pointer to | ||
| * by the "buffer" argument. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclFormatInt(buffer, n) | ||
| char *buffer; /* Points to the storage into which the | ||
| * formatted characters are written. */ | ||
| long n; /* The integer to format. */ | ||
| { | ||
| long intVal; | ||
| int i; | ||
| int numFormatted, j; | ||
| char *digits = "0123456789"; | ||
| /* | ||
| * Check first whether "n" is zero. | ||
| */ | ||
| if (n == 0) { | ||
| buffer[0] = '0'; | ||
| buffer[1] = 0; | ||
| return 1; | ||
| } | ||
| /* | ||
| * Check whether "n" is the maximum negative value. This is | ||
| * -2^(m-1) for an m-bit word, and has no positive equivalent; | ||
| * negating it produces the same value. | ||
| */ | ||
| if (n == -n) { | ||
| sprintf(buffer, "%ld", n); | ||
| return strlen(buffer); | ||
| } | ||
| /* | ||
| * Generate the characters of the result backwards in the buffer. | ||
| */ | ||
| intVal = (n < 0? -n : n); | ||
| i = 0; | ||
| buffer[0] = '\0'; | ||
| do { | ||
| i++; | ||
| buffer[i] = digits[intVal % 10]; | ||
| intVal = intVal/10; | ||
| } while (intVal > 0); | ||
| if (n < 0) { | ||
| i++; | ||
| buffer[i] = '-'; | ||
| } | ||
| numFormatted = i; | ||
| /* | ||
| * Now reverse the characters. | ||
| */ | ||
| for (j = 0; j < i; j++, i--) { | ||
| char tmp = buffer[i]; | ||
| buffer[i] = buffer[j]; | ||
| buffer[j] = tmp; | ||
| } | ||
| return numFormatted; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclLooksLikeInt -- | ||
| * | ||
| * This procedure decides whether the leading characters of a | ||
| * string look like an integer or something else (such as a | ||
| * floating-point number or string). | ||
| * | ||
| * Results: | ||
| * The return value is 1 if the leading characters of p look | ||
| * like a valid Tcl integer. If they look like a floating-point | ||
| * number (e.g. "e01" or "2.4"), or if they don't look like a | ||
| * number at all, then 0 is returned. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclLooksLikeInt(bytes, length) | ||
| register char *bytes; /* Points to first byte of the string. */ | ||
| int length; /* Number of bytes in the string. If < 0 | ||
| * bytes up to the first null byte are | ||
| * considered (if they may appear in an | ||
| * integer). */ | ||
| { | ||
| register char *p, *end; | ||
| if (length < 0) { | ||
| length = (bytes? strlen(bytes) : 0); | ||
| } | ||
| end = (bytes + length); | ||
| p = bytes; | ||
| while ((p < end) && isspace(UCHAR(*p))) { /* INTL: ISO space. */ | ||
| p++; | ||
| } | ||
| if (p == end) { | ||
| return 0; | ||
| } | ||
| if ((*p == '+') || (*p == '-')) { | ||
| p++; | ||
| } | ||
| if ((p == end) || !isdigit(UCHAR(*p))) { /* INTL: digit */ | ||
| return 0; | ||
| } | ||
| p++; | ||
| while ((p < end) && isdigit(UCHAR(*p))) { /* INTL: digit */ | ||
| p++; | ||
| } | ||
| if (p == end) { | ||
| return 1; | ||
| } | ||
| if ((*p != '.') && (*p != 'e') && (*p != 'E')) { | ||
| return 1; | ||
| } | ||
| return 0; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclGetIntForIndex -- | ||
| * | ||
| * This procedure returns an integer corresponding to the list index | ||
| * held in a Tcl object. The Tcl object's value is expected to be | ||
| * either an integer or a string of the form "end([+-]integer)?". | ||
| * | ||
| * Results: | ||
| * The return value is normally TCL_OK, which means that the index was | ||
| * successfully stored into the location referenced by "indexPtr". If | ||
| * the Tcl object referenced by "objPtr" has the value "end", the | ||
| * value stored is "endValue". If "objPtr"s values is not of the form | ||
| * "end([+-]integer)?" and | ||
| * can not be converted to an integer, TCL_ERROR is returned and, if | ||
| * "interp" is non-NULL, an error message is left in the interpreter's | ||
| * result object. | ||
| * | ||
| * Side effects: | ||
| * The object referenced by "objPtr" might be converted to an | ||
| * integer object. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclGetIntForIndex(interp, objPtr, endValue, indexPtr) | ||
| Tcl_Interp *interp; /* Interpreter to use for error reporting. | ||
| * If NULL, then no error message is left | ||
| * after errors. */ | ||
| Tcl_Obj *objPtr; /* Points to an object containing either | ||
| * "end" or an integer. */ | ||
| int endValue; /* The value to be stored at "indexPtr" if | ||
| * "objPtr" holds "end". */ | ||
| int *indexPtr; /* Location filled in with an integer | ||
| * representing an index. */ | ||
| { | ||
| char *bytes; | ||
| int length, offset; | ||
| if (objPtr->typePtr == &tclIntType) { | ||
| *indexPtr = (int)objPtr->internalRep.longValue; | ||
| return TCL_OK; | ||
| } | ||
| bytes = Tcl_GetStringFromObj(objPtr, &length); | ||
| if ((*bytes != 'e') || (strncmp(bytes, "end", | ||
| (size_t)((length > 3) ? 3 : length)) != 0)) { | ||
| if (Tcl_GetIntFromObj(NULL, objPtr, &offset) != TCL_OK) { | ||
| goto intforindex_error; | ||
| } | ||
| *indexPtr = offset; | ||
| return TCL_OK; | ||
| } | ||
| if (length <= 3) { | ||
| *indexPtr = endValue; | ||
| } else if (bytes[3] == '-') { | ||
| /* | ||
| * This is our limited string expression evaluator | ||
| */ | ||
| if (Tcl_GetInt(interp, bytes+3, &offset) != TCL_OK) { | ||
| return TCL_ERROR; | ||
| } | ||
| *indexPtr = endValue + offset; | ||
| } else { | ||
| intforindex_error: | ||
| if ((Interp *)interp != NULL) { | ||
| Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), | ||
| "bad index \"", bytes, | ||
| "\": must be integer or end?-integer?", (char *) NULL); | ||
| TclCheckBadOctal(interp, bytes); | ||
| } | ||
| return TCL_ERROR; | ||
| } | ||
| return TCL_OK; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * TclCheckBadOctal -- | ||
| * | ||
| * This procedure checks for a bad octal value and appends a | ||
| * meaningful error to the interp's result. | ||
| * | ||
| * Results: | ||
| * 1 if the argument was a bad octal, else 0. | ||
| * | ||
| * Side effects: | ||
| * The interpreter's result is modified. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| TclCheckBadOctal(interp, value) | ||
| Tcl_Interp *interp; /* Interpreter to use for error reporting. | ||
| * If NULL, then no error message is left | ||
| * after errors. */ | ||
| char *value; /* String to check. */ | ||
| { | ||
| register char *p = value; | ||
| /* | ||
| * A frequent mistake is invalid octal values due to an unwanted | ||
| * leading zero. Try to generate a meaningful error message. | ||
| */ | ||
| while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ | ||
| p++; | ||
| } | ||
| if (*p == '+' || *p == '-') { | ||
| p++; | ||
| } | ||
| if (*p == '0') { | ||
| while (isdigit(UCHAR(*p))) { /* INTL: digit. */ | ||
| p++; | ||
| } | ||
| while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ | ||
| p++; | ||
| } | ||
| if (*p == '\0') { | ||
| /* Reached end of string */ | ||
| if (interp != NULL) { | ||
| Tcl_AppendResult(interp, " (looks like invalid octal number)", | ||
| (char *) NULL); | ||
| } | ||
| return 1; | ||
| } | ||
| } | ||
| return 0; | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetNameOfExecutable -- | ||
| * | ||
| * This procedure simply returns a pointer to the internal full | ||
| * path name of the executable file as computed by | ||
| * Tcl_FindExecutable. This procedure call is the C API | ||
| * equivalent to the "info nameofexecutable" command. | ||
| * | ||
| * Results: | ||
| * A pointer to the internal string or NULL if the internal full | ||
| * path name has not been computed or unknown. | ||
| * | ||
| * Side effects: | ||
| * The object referenced by "objPtr" might be converted to an | ||
| * integer object. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| CONST char * | ||
| Tcl_GetNameOfExecutable() | ||
| { | ||
| return (tclExecutableName); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_GetCwd -- | ||
| * | ||
| * This function replaces the library version of getcwd(). | ||
| * | ||
| * Results: | ||
| * The result is a pointer to a string specifying the current | ||
| * directory, or NULL if the current directory could not be | ||
| * determined. If NULL is returned, an error message is left in the | ||
| * interp's result. Storage for the result string is allocated in | ||
| * bufferPtr; the caller must call Tcl_DStringFree() when the result | ||
| * is no longer needed. | ||
| * | ||
| * Side effects: | ||
| * None. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| char * | ||
| Tcl_GetCwd(interp, cwdPtr) | ||
| Tcl_Interp *interp; | ||
| Tcl_DString *cwdPtr; | ||
| { | ||
| return TclpGetCwd(interp, cwdPtr); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_Chdir -- | ||
| * | ||
| * This function replaces the library version of chdir(). | ||
| * | ||
| * Results: | ||
| * See chdir() documentation. | ||
| * | ||
| * Side effects: | ||
| * See chdir() documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_Chdir(dirName) | ||
| CONST char *dirName; | ||
| { | ||
| return TclpChdir(dirName); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_Access -- | ||
| * | ||
| * This function replaces the library version of access(). | ||
| * | ||
| * Results: | ||
| * See access() documentation. | ||
| * | ||
| * Side effects: | ||
| * See access() documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_Access(path, mode) | ||
| CONST char *path; /* Path of file to access (UTF-8). */ | ||
| int mode; /* Permission setting. */ | ||
| { | ||
| return TclAccess(path, mode); | ||
| } | ||
| /* | ||
| *---------------------------------------------------------------------- | ||
| * | ||
| * Tcl_Stat -- | ||
| * | ||
| * This function replaces the library version of stat(). | ||
| * | ||
| * Results: | ||
| * See stat() documentation. | ||
| * | ||
| * Side effects: | ||
| * See stat() documentation. | ||
| * | ||
| *---------------------------------------------------------------------- | ||
| */ | ||
| int | ||
| Tcl_Stat(path, bufPtr) | ||
| CONST char *path; /* Path of file to stat (in UTF-8). */ | ||
| struct stat *bufPtr; /* Filled with results of stat call. */ | ||
| { | ||
| return TclStat(path, bufPtr); | ||
| } | ||
| /* $History: tclutil.c $ | ||
| * | ||
| * ***************** Version 1 ***************** | ||
| * User: Dtashley Date: 1/02/01 Time: 12:50a | ||
| * Created in $/IjuScripter, IjuConsole/Source/Tcl Base | ||
| * Initial check-in. | ||
| */ | ||
| /* End of TCLUTIL.C */ | ||
| 1 | /* $Header$ */ | |
| 2 | /* | |
| 3 | * tclUtil.c -- | |
| 4 | * | |
| 5 | * This file contains utility procedures that are used by many Tcl | |
| 6 | * commands. | |
| 7 | * | |
| 8 | * Copyright (c) 1987-1993 The Regents of the University of California. | |
| 9 | * Copyright (c) 1994-1998 Sun Microsystems, Inc. | |
| 10 | * | |
| 11 | * See the file "license.terms" for information on usage and redistribution | |
| 12 | * of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
| 13 | * | |
| 14 | * RCS: @(#) $Id: tclutil.c,v 1.1.1.1 2001/06/13 04:47:21 dtashley Exp $ | |
| 15 | */ | |
| 16 | ||
| 17 | #include "tclInt.h" | |
| 18 | #include "tclPort.h" | |
| 19 | ||
| 20 | /* | |
| 21 | * The following variable holds the full path name of the binary | |
| 22 | * from which this application was executed, or NULL if it isn't | |
| 23 | * know. The value of the variable is set by the procedure | |
| 24 | * Tcl_FindExecutable. The storage space is dynamically allocated. | |
| 25 | */ | |
| 26 | ||
| 27 | char *tclExecutableName = NULL; | |
| 28 | char *tclNativeExecutableName = NULL; | |
| 29 | ||
| 30 | /* | |
| 31 | * The following values are used in the flags returned by Tcl_ScanElement | |
| 32 | * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also | |
| 33 | * defined in tcl.h; make sure its value doesn't overlap with any of the | |
| 34 | * values below. | |
| 35 | * | |
| 36 | * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in | |
| 37 | * braces (e.g. it contains unmatched braces, | |
| 38 | * or ends in a backslash character, or user | |
| 39 | * just doesn't want braces); handle all | |
| 40 | * special characters by adding backslashes. | |
| 41 | * USE_BRACES - 1 means the string contains a special | |
| 42 | * character that can be handled simply by | |
| 43 | * enclosing the entire argument in braces. | |
| 44 | * BRACES_UNMATCHED - 1 means that braces aren't properly matched | |
| 45 | * in the argument. | |
| 46 | */ | |
| 47 | ||
| 48 | #define USE_BRACES 2 | |
| 49 | #define BRACES_UNMATCHED 4 | |
| 50 | ||
| 51 | /* | |
| 52 | * The following values determine the precision used when converting | |
| 53 | * floating-point values to strings. This information is linked to all | |
| 54 | * of the tcl_precision variables in all interpreters via the procedure | |
| 55 | * TclPrecTraceProc. | |
| 56 | */ | |
| 57 | ||
| 58 | static char precisionString[10] = "12"; | |
| 59 | /* The string value of all the tcl_precision | |
| 60 | * variables. */ | |
| 61 | static char precisionFormat[10] = "%.12g"; | |
| 62 | /* The format string actually used in calls | |
| 63 | * to sprintf. */ | |
| 64 | TCL_DECLARE_MUTEX(precisionMutex) | |
| 65 | ||
| 66 | ||
| 67 | /* | |
| 68 | *---------------------------------------------------------------------- | |
| 69 | * | |
| 70 | * TclFindElement -- | |
| 71 | * | |
| 72 | * Given a pointer into a Tcl list, locate the first (or next) | |
| 73 | * element in the list. | |
| 74 | * | |
| 75 | * Results: | |
| 76 | * The return value is normally TCL_OK, which means that the | |
| 77 | * element was successfully located. If TCL_ERROR is returned | |
| 78 | * it means that list didn't have proper list structure; | |
| 79 | * the interp's result contains a more detailed error message. | |
| 80 | * | |
| 81 | * If TCL_OK is returned, then *elementPtr will be set to point to the | |
| 82 | * first element of list, and *nextPtr will be set to point to the | |
| 83 | * character just after any white space following the last character | |
| 84 | * that's part of the element. If this is the last argument in the | |
| 85 | * list, then *nextPtr will point just after the last character in the | |
| 86 | * list (i.e., at the character at list+listLength). If sizePtr is | |
| 87 | * non-NULL, *sizePtr is filled in with the number of characters in the | |
| 88 | * element. If the element is in braces, then *elementPtr will point | |
| 89 | * to the character after the opening brace and *sizePtr will not | |
| 90 | * include either of the braces. If there isn't an element in the list, | |
| 91 | * *sizePtr will be zero, and both *elementPtr and *termPtr will point | |
| 92 | * just after the last character in the list. Note: this procedure does | |
| 93 | * NOT collapse backslash sequences. | |
| 94 | * | |
| 95 | * Side effects: | |
| 96 | * None. | |
| 97 | * | |
| 98 | *---------------------------------------------------------------------- | |
| 99 | */ | |
| 100 | ||
| 101 | int | |
| 102 | TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, | |
| 103 | bracePtr) | |
| 104 | Tcl_Interp *interp; /* Interpreter to use for error reporting. | |
| 105 | * If NULL, then no error message is left | |
| 106 | * after errors. */ | |
| 107 | CONST char *list; /* Points to the first byte of a string | |
| 108 | * containing a Tcl list with zero or more | |
| 109 | * elements (possibly in braces). */ | |
| 110 | int listLength; /* Number of bytes in the list's string. */ | |
| 111 | CONST char **elementPtr; /* Where to put address of first significant | |
| 112 | * character in first element of list. */ | |
| 113 | CONST char **nextPtr; /* Fill in with location of character just | |
| 114 | * after all white space following end of | |
| 115 | * argument (next arg or end of list). */ | |
| 116 | int *sizePtr; /* If non-zero, fill in with size of | |
| 117 | * element. */ | |
| 118 | int *bracePtr; /* If non-zero, fill in with non-zero/zero | |
| 119 | * to indicate that arg was/wasn't | |
| 120 | * in braces. */ | |
| 121 | { | |
| 122 | CONST char *p = list; | |
| 123 | CONST char *elemStart; /* Points to first byte of first element. */ | |
| 124 | CONST char *limit; /* Points just after list's last byte. */ | |
| 125 | int openBraces = 0; /* Brace nesting level during parse. */ | |
| 126 | int inQuotes = 0; | |
| 127 | int size = 0; /* lint. */ | |
| 128 | int numChars; | |
| 129 | CONST char *p2; | |
| 130 | ||
| 131 | /* | |
| 132 | * Skim off leading white space and check for an opening brace or | |
| 133 | * quote. We treat embedded NULLs in the list as bytes belonging to | |
| 134 | * a list element. | |
| 135 | */ | |
| 136 | ||
| 137 | limit = (list + listLength); | |
| 138 | while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ | |
| 139 | p++; | |
| 140 | } | |
| 141 | if (p == limit) { /* no element found */ | |
| 142 | elemStart = limit; | |
| 143 | goto done; | |
| 144 | } | |
| 145 | ||
| 146 | if (*p == '{') { | |
| 147 | openBraces = 1; | |
| 148 | p++; | |
| 149 | } else if (*p == '"') { | |
| 150 | inQuotes = 1; | |
| 151 | p++; | |
| 152 | } | |
| 153 | elemStart = p; | |
| 154 | if (bracePtr != 0) { | |
| 155 | *bracePtr = openBraces; | |
| 156 | } | |
| 157 | ||
| 158 | /* | |
| 159 | * Find element's end (a space, close brace, or the end of the string). | |
| 160 | */ | |
| 161 | ||
| 162 | while (p < limit) { | |
| 163 | switch (*p) { | |
| 164 | ||
| 165 | /* | |
| 166 | * Open brace: don't treat specially unless the element is in | |
| 167 | * braces. In this case, keep a nesting count. | |
| 168 | */ | |
| 169 | ||
| 170 | case '{': | |
| 171 | if (openBraces != 0) { | |
| 172 | openBraces++; | |
| 173 | } | |
| 174 | break; | |
| 175 | ||
| 176 | /* | |
| 177 | * Close brace: if element is in braces, keep nesting count and | |
| 178 | * quit when the last close brace is seen. | |
| 179 | */ | |
| 180 | ||
| 181 | case '}': | |
| 182 | if (openBraces > 1) { | |
| 183 | openBraces--; | |
| 184 | } else if (openBraces == 1) { | |
| 185 | size = (p - elemStart); | |
| 186 | p++; | |
| 187 | if ((p >= limit) | |
| 188 | || isspace(UCHAR(*p))) { /* INTL: ISO space. */ | |
| 189 | goto done; | |
| 190 | } | |
| 191 | ||
| 192 | /* | |
| 193 | * Garbage after the closing brace; return an error. | |
| 194 | */ | |
| 195 | ||
| 196 | if (interp != NULL) { | |
| 197 | char buf[100]; | |
| 198 | ||
| 199 | p2 = p; | |
| 200 | while ((p2 < limit) | |
| 201 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ | |
| 202 | && (p2 < p+20)) { | |
| 203 | p2++; | |
| 204 | } | |
| 205 | sprintf(buf, | |
| 206 | "list element in braces followed by \"%.*s\" instead of space", | |
| 207 | (int) (p2-p), p); | |
| 208 | Tcl_SetResult(interp, buf, TCL_VOLATILE); | |
| 209 | } | |
| 210 | return TCL_ERROR; | |
| 211 | } | |
| 212 | break; | |
| 213 | ||
| 214 | /* | |
| 215 | * Backslash: skip over everything up to the end of the | |
| 216 | * backslash sequence. | |
| 217 | */ | |
| 218 | ||
| 219 | case '\\': { | |
| 220 | Tcl_UtfBackslash(p, &numChars, NULL); | |
| 221 | p += (numChars - 1); | |
| 222 | break; | |
| 223 | } | |
| 224 | ||
| 225 | /* | |
| 226 | * Space: ignore if element is in braces or quotes; otherwise | |
| 227 | * terminate element. | |
| 228 | */ | |
| 229 | ||
| 230 | case ' ': | |
| 231 | case '\f': | |
| 232 | case '\n': | |
| 233 | case '\r': | |
| 234 | case '\t': | |
| 235 | case '\v': | |
| 236 | if ((openBraces == 0) && !inQuotes) { | |
| 237 | size = (p - elemStart); | |
| 238 | goto done; | |
| 239 | } | |
| 240 | break; | |
| 241 | ||
| 242 | /* | |
| 243 | * Double-quote: if element is in quotes then terminate it. | |
| 244 | */ | |
| 245 | ||
| 246 | case '"': | |
| 247 | if (inQuotes) { | |
| 248 | size = (p - elemStart); | |
| 249 | p++; | |
| 250 | if ((p >= limit) | |
| 251 | || isspace(UCHAR(*p))) { /* INTL: ISO space */ | |
| 252 | goto done; | |
| 253 | } | |
| 254 | ||
| 255 | /* | |
| 256 | * Garbage after the closing quote; return an error. | |
| 257 | */ | |
| 258 | ||
| 259 | if (interp != NULL) { | |
| 260 | char buf[100]; | |
| 261 | ||
| 262 | p2 = p; | |
| 263 | while ((p2 < limit) | |
| 264 | && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ | |
| 265 | && (p2 < p+20)) { | |
| 266 | p2++; | |
| 267 | } | |
| 268 | sprintf(buf, | |
| 269 | "list element in quotes followed by \"%.*s\" %s", | |
| 270 | (int) (p2-p), p, "instead of space"); | |
| 271 | Tcl_SetResult(interp, buf, TCL_VOLATILE); | |
| 272 | } | |
| 273 | return TCL_ERROR; | |
| 274 | } | |
| 275 | break; | |
| 276 | } | |
| 277 | p++; | |
| 278 | } | |
| 279 | ||
| 280 | ||
| 281 | /* | |
| 282 | * End of list: terminate element. | |
| 283 | */ | |
| 284 | ||
| 285 | if (p == limit) { | |
| 286 | if (openBraces != 0) { | |
| 287 | if (interp != NULL) { | |
| 288 | Tcl_SetResult(interp, "unmatched open brace in list", | |
| 289 | TCL_STATIC); | |
| 290 | } | |
| 291 | return TCL_ERROR; | |
| 292 | } else if (inQuotes) { | |
| 293 | if (interp != NULL) { | |
| 294 | Tcl_SetResult(interp, "unmatched open quote in list", | |
| 295 | TCL_STATIC); | |
| 296 | } | |
| 297 | return TCL_ERROR; | |
| 298 | } | |
| 299 | size = (p - elemStart); | |
| 300 | } | |
| 301 | ||
| 302 | done: | |
| 303 | while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ | |
| 304 | p++; | |
| 305 | } | |
| 306 | *elementPtr = elemStart; | |
| 307 | *nextPtr = p; | |
| 308 | if (sizePtr != 0) { | |
| 309 | *sizePtr = size; | |
| 310 | } | |
| 311 | return TCL_OK; | |
| 312 | } | |
| 313 | ||
| 314 | /* | |
| 315 | *---------------------------------------------------------------------- | |
| 316 | * | |
| 317 | * TclCopyAndCollapse -- | |
| 318 | * | |
| 319 | * Copy a string and eliminate any backslashes that aren't in braces. | |
| 320 | * | |
| 321 | * Results: | |
| 322 | * There is no return value. Count characters get copied from src to | |
| 323 | * dst. Along the way, if backslash sequences are found outside braces, | |
| 324 | * the backslashes are eliminated in the copy. After scanning count | |
| 325 | * chars from source, a null character is placed at the end of dst. | |
| 326 | * Returns the number of characters that got copied. | |
| 327 | * | |
| 328 | * Side effects: | |
| 329 | * None. | |
| 330 | * | |
| 331 | *---------------------------------------------------------------------- | |
| 332 | */ | |
| 333 | ||
| 334 | int | |
| 335 | TclCopyAndCollapse(count, src, dst) | |
| 336 | int count; /* Number of characters to copy from src. */ | |
| 337 | CONST char *src; /* Copy from here... */ | |
| 338 | char *dst; /* ... to here. */ | |
| 339 | { | |
| 340 | register char c; | |
| 341 | int numRead; | |
| 342 | int newCount = 0; | |
| 343 | int backslashCount; | |
| 344 | ||
| 345 | for (c = *src; count > 0; src++, c = *src, count--) { | |
| 346 | if (c == '\\') { | |
| 347 | backslashCount = Tcl_UtfBackslash(src, &numRead, dst); | |
| 348 | dst += backslashCount; | |
| 349 | newCount += backslashCount; | |
| 350 | src += numRead-1; | |
| 351 | count -= numRead-1; | |
| 352 | } else { | |
| 353 | *dst = c; | |
| 354 | dst++; | |
| 355 | newCount++; | |
| 356 | } | |
| 357 | } | |
| 358 | *dst = 0; | |
| 359 | return newCount; | |
| 360 | } | |
| 361 | ||
| 362 | /* | |
| 363 | *---------------------------------------------------------------------- | |
| 364 | * | |
| 365 | * Tcl_SplitList -- | |
| 366 | * | |
| 367 | * Splits a list up into its constituent fields. | |
| 368 | * | |
| 369 | * Results | |
| 370 | * The return value is normally TCL_OK, which means that | |
| 371 | * the list was successfully split up. If TCL_ERROR is | |
| 372 | * returned, it means that "list" didn't have proper list | |
| 373 | * structure; the interp's result will contain a more detailed | |
| 374 | * error message. | |
| 375 | * | |
| 376 | * *argvPtr will be filled in with the address of an array | |
| 377 | * whose elements point to the elements of list, in order. | |
| 378 | * *argcPtr will get filled in with the number of valid elements | |
| 379 | * in the array. A single block of memory is dynamically allocated | |
| 380 | * to hold both the argv array and a copy of the list (with | |
| 381 | * backslashes and braces removed in the standard way). | |
| 382 | * The caller must eventually free this memory by calling free() | |
| 383 | * on *argvPtr. Note: *argvPtr and *argcPtr are only modified | |
| 384 | * if the procedure returns normally. | |
| 385 | * | |
| 386 | * Side effects: | |
| 387 | * Memory is allocated. | |
| 388 | * | |
| 389 | *---------------------------------------------------------------------- | |
| 390 | */ | |
| 391 | ||
| 392 | int | |
| 393 | Tcl_SplitList(interp, list, argcPtr, argvPtr) | |
| 394 | Tcl_Interp *interp; /* Interpreter to use for error reporting. | |
| 395 | * If NULL, no error message is left. */ | |
| 396 | CONST char *list; /* Pointer to string with list structure. */ | |
| 397 | int *argcPtr; /* Pointer to location to fill in with | |
| 398 | * the number of elements in the list. */ | |
| 399 | char ***argvPtr; /* Pointer to place to store pointer to | |
| 400 | * array of pointers to list elements. */ | |
| 401 | { | |
| 402 | char **argv; | |
| 403 | CONST char *l; | |
| 404 | char *p; | |
| 405 | int length, size, i, result, elSize, brace; | |
| 406 | CONST char *element; | |
| 407 | ||
| 408 | /* | |
| 409 | * Figure out how much space to allocate. There must be enough | |
| 410 | * space for both the array of pointers and also for a copy of | |
| 411 | * the list. To estimate the number of pointers needed, count | |
| 412 | * the number of space characters in the list. | |
| 413 | */ | |
| 414 | ||
| 415 | for (size = 1, l = list; *l != 0; l++) { | |
| 416 | if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ | |
| 417 | size++; | |
| 418 | } | |
| 419 | } | |
| 420 | size++; /* Leave space for final NULL pointer. */ | |
| 421 | argv = (char **) ckalloc((unsigned) | |
| 422 | ((size * sizeof(char *)) + (l - list) + 1)); | |
| 423 | length = strlen(list); | |
| 424 | for (i = 0, p = ((char *) argv) + size*sizeof(char *); | |
| 425 | *list != 0; i++) { | |
| 426 | CONST char *prevList = list; | |
| 427 | ||
| 428 | result = TclFindElement(interp, list, length, &element, | |
| 429 | &list, &elSize, &brace); | |
| 430 | length -= (list - prevList); | |
| 431 | if (result != TCL_OK) { | |
| 432 | ckfree((char *) argv); | |
| 433 | return result; | |
| 434 | } | |
| 435 | if (*element == 0) { | |
| 436 | break; | |
| 437 | } | |
| 438 | if (i >= size) { | |
| 439 | ckfree((char *) argv); | |
| 440 | if (interp != NULL) { | |
| 441 | Tcl_SetResult(interp, "internal error in Tcl_SplitList", | |
| 442 | TCL_STATIC); | |
| 443 | } | |
| 444 | return TCL_ERROR; | |
| 445 | } | |
| 446 | argv[i] = p; | |
| 447 | if (brace) { | |
| 448 | memcpy((VOID *) p, (VOID *) element, (size_t) elSize); | |
| 449 | p += elSize; | |
| 450 | *p = 0; | |
| 451 | p++; | |
| 452 | } else { | |
| 453 | TclCopyAndCollapse(elSize, element, p); | |
| 454 | p += elSize+1; | |
| 455 | } | |
| 456 | } | |
| 457 | ||
| 458 | argv[i] = NULL; | |
| 459 | *argvPtr = argv; | |
| 460 | *argcPtr = i; | |
| 461 | return TCL_OK; | |
| 462 | } | |
| 463 | ||
| 464 | /* | |
| 465 | *---------------------------------------------------------------------- | |
| 466 | * | |
| 467 | * Tcl_ScanElement -- | |
| 468 | * | |
| 469 | * This procedure is a companion procedure to Tcl_ConvertElement. | |
| 470 | * It scans a string to see what needs to be done to it (e.g. add | |
| 471 | * backslashes or enclosing braces) to make the string into a | |
| 472 | * valid Tcl list element. | |
| 473 | * | |
| 474 | * Results: | |
| 475 | * The return value is an overestimate of the number of characters | |
| 476 | * that will be needed by Tcl_ConvertElement to produce a valid | |
| 477 | * list element from string. The word at *flagPtr is filled in | |
| 478 | * with a value needed by Tcl_ConvertElement when doing the actual | |
| 479 | * conversion. | |
| 480 | * | |
| 481 | * Side effects: | |
| 482 | * None. | |
| 483 | * | |
| 484 | *---------------------------------------------------------------------- | |
| 485 | */ | |
| 486 | ||
| 487 | int | |
| 488 | Tcl_ScanElement(string, flagPtr) | |
| 489 | register CONST char *string; /* String to convert to list element. */ | |
| 490 | register int *flagPtr; /* Where to store information to guide | |
| 491 | * Tcl_ConvertCountedElement. */ | |
| 492 | { | |
| 493 | return Tcl_ScanCountedElement(string, -1, flagPtr); | |
| 494 | } | |
| 495 | ||
| 496 | /* | |
| 497 | *---------------------------------------------------------------------- | |
| 498 | * | |
| 499 | * Tcl_ScanCountedElement -- | |
| 500 | * | |
| 501 | * This procedure is a companion procedure to | |
| 502 | * Tcl_ConvertCountedElement. It scans a string to see what | |
| 503 | * needs to be done to it (e.g. add backslashes or enclosing | |
| 504 | * braces) to make the string into a valid Tcl list element. | |
| 505 | * If length is -1, then the string is scanned up to the first | |
| 506 | * null byte. | |
| 507 | * | |
| 508 | * Results: | |
| 509 | * The return value is an overestimate of the number of characters | |
| 510 | * that will be needed by Tcl_ConvertCountedElement to produce a | |
| 511 | * valid list element from string. The word at *flagPtr is | |
| 512 | * filled in with a value needed by Tcl_ConvertCountedElement | |
| 513 | * when doing the actual conversion. | |
| 514 | * | |
| 515 | * Side effects: | |
| 516 | * None. | |
| 517 | * | |
| 518 | *---------------------------------------------------------------------- | |
| 519 | */ | |
| 520 | ||
| 521 | int | |
| 522 | Tcl_ScanCountedElement(string, length, flagPtr) | |
| 523 | CONST char *string; /* String to convert to Tcl list element. */ | |
| 524 | int length; /* Number of bytes in string, or -1. */ | |
| 525 | int *flagPtr; /* Where to store information to guide | |
| 526 | * Tcl_ConvertElement. */ | |
| 527 | { | |
| 528 | int flags, nestingLevel; | |
| 529 | register CONST char *p, *lastChar; | |
| 530 | ||
| 531 | /* | |
| 532 | * This procedure and Tcl_ConvertElement together do two things: | |
| 533 | * | |
| 534 | * 1. They produce a proper list, one that will yield back the | |
| 535 | * argument strings when evaluated or when disassembled with | |
| 536 | * Tcl_SplitList. This is the most important thing. | |
| 537 | * | |
| 538 | * 2. They try to produce legible output, which means minimizing the | |
| 539 | * use of backslashes (using braces instead). However, there are | |
| 540 | * some situations where backslashes must be used (e.g. an element | |
| 541 | * like "{abc": the leading brace will have to be backslashed. | |
| 542 | * For each element, one of three things must be done: | |
| 543 | * | |
| 544 | * (a) Use the element as-is (it doesn't contain any special | |
| 545 | * characters). This is the most desirable option. | |
| 546 | * | |
| 547 | * (b) Enclose the element in braces, but leave the contents alone. | |
| 548 | * This happens if the element contains embedded space, or if it | |
| 549 | * contains characters with special interpretation ($, [, ;, or \), | |
| 550 | * or if it starts with a brace or double-quote, or if there are | |
| 551 | * no characters in the element. | |
| 552 | * | |
| 553 | * (c) Don't enclose the element in braces, but add backslashes to | |
| 554 | * prevent special interpretation of special characters. This is a | |
| 555 | * last resort used when the argument would normally fall under case | |
| 556 | * (b) but contains unmatched braces. It also occurs if the last | |
| 557 | * character of the argument is a backslash or if the element contains | |
| 558 | * a backslash followed by newline. | |
| 559 | * | |
| 560 | * The procedure figures out how many bytes will be needed to store | |
| 561 | * the result (actually, it overestimates). It also collects information | |
| 562 | * about the element in the form of a flags word. | |
| 563 | * | |
| 564 | * Note: list elements produced by this procedure and | |
| 565 | * Tcl_ConvertCountedElement must have the property that they can be | |
| 566 | * enclosing in curly braces to make sub-lists. This means, for | |
| 567 | * example, that we must not leave unmatched curly braces in the | |
| 568 | * resulting list element. This property is necessary in order for | |
| 569 | * procedures like Tcl_DStringStartSublist to work. | |
| 570 | */ | |
| 571 | ||
| 572 | nestingLevel = 0; | |
| 573 | flags = 0; | |
| 574 | if (string == NULL) { | |
| 575 | string = ""; | |
| 576 | } | |
| 577 | if (length == -1) { | |
| 578 | length = strlen(string); | |
| 579 | } | |
| 580 | lastChar = string + length; | |
| 581 | p = string; | |
| 582 | if ((p == lastChar) || (*p == '{') || (*p == '"')) { | |
| 583 | flags |= USE_BRACES; | |
| 584 | } | |
| 585 | for ( ; p < lastChar; p++) { | |
| 586 | switch (*p) { | |
| 587 | case '{': | |
| 588 | nestingLevel++; | |
| 589 | break; | |
| 590 | case '}': | |
| 591 | nestingLevel--; | |
| 592 | if (nestingLevel < 0) { | |
| 593 | flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; | |
| 594 | } | |
| 595 | break; | |
| 596 | case '[': | |
| 597 | case '$': | |
| 598 | case ';': | |
| 599 | case ' ': | |
| 600 | case '\f': | |
| 601 | case '\n': | |
| 602 | case '\r': | |
| 603 | case '\t': | |
| 604 | case '\v': | |
| 605 | flags |= USE_BRACES; | |
| 606 | break; | |
| 607 | case '\\': | |
| 608 | if ((p+1 == lastChar) || (p[1] == '\n')) { | |
| 609 | flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; | |
| 610 | } else { | |
| 611 | int size; | |
| 612 | ||
| 613 | Tcl_UtfBackslash(p, &size, NULL); | |
| 614 | p += size-1; | |
| 615 | flags |= USE_BRACES; | |
| 616 | } | |
| 617 | break; | |
| 618 | } | |
| 619 | } | |
| 620 | if (nestingLevel != 0) { | |
| 621 | flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; | |
| 622 | } | |
| 623 | *flagPtr = flags; | |
| 624 | ||
| 625 | /* | |
| 626 | * Allow enough space to backslash every character plus leave | |
| 627 | * two spaces for braces. | |
| 628 | */ | |
| 629 | ||
| 630 | return 2*(p-string) + 2; | |
| 631 | } | |
| 632 | ||
| 633 | /* | |
| 634 | *---------------------------------------------------------------------- | |
| 635 | * | |
| 636 | * Tcl_ConvertElement -- | |
| 637 | * | |
| 638 | * This is a companion procedure to Tcl_ScanElement. Given | |
| 639 | * the information produced by Tcl_ScanElement, this procedure | |
| 640 | * converts a string to a list element equal to that string. | |
| 641 | * | |
| 642 | * Results: | |
| 643 | * Information is copied to *dst in the form of a list element | |
| 644 | * identical to src (i.e. if Tcl_SplitList is applied to dst it | |
| 645 | * will produce a string identical to src). The return value is | |
| 646 | * a count of the number of characters copied (not including the | |
| 647 | * terminating NULL character). | |
| 648 | * | |
| 649 | * Side effects: | |
| 650 | * None. | |
| 651 | * | |
| 652 | *---------------------------------------------------------------------- | |
| 653 | */ | |
| 654 | ||
| 655 | int | |
| 656 | Tcl_ConvertElement(src, dst, flags) | |
| 657 | register CONST char *src; /* Source information for list element. */ | |
| 658 | register char *dst; /* Place to put list-ified element. */ | |
| 659 | register int flags; /* Flags produced by Tcl_ScanElement. */ | |
| 660 | { | |
| 661 | return Tcl_ConvertCountedElement(src, -1, dst, flags); | |
| 662 | } | |
| 663 | ||
| 664 | /* | |
| 665 | *---------------------------------------------------------------------- | |
| 666 | * | |
| 667 | * Tcl_ConvertCountedElement -- | |
| 668 | * | |
| 669 | * This is a companion procedure to Tcl_ScanCountedElement. Given | |
| 670 | * the information produced by Tcl_ScanCountedElement, this | |
| 671 | * procedure converts a string to a list element equal to that | |
| 672 | * string. | |
| 673 | * | |
| 674 | * Results: | |
| 675 | * Information is copied to *dst in the form of a list element | |
| 676 | * identical to src (i.e. if Tcl_SplitList is applied to dst it | |
| 677 | * will produce a string identical to src). The return value is | |
| 678 | * a count of the number of characters copied (not including the | |
| 679 | * terminating NULL character). | |
| 680 | * | |
| 681 | * Side effects: | |
| 682 | * None. | |
| 683 | * | |
| 684 | *---------------------------------------------------------------------- | |
| 685 | */ | |
| 686 | ||
| 687 | int | |
| 688 | Tcl_ConvertCountedElement(src, length, dst, flags) | |
| 689 | register CONST char *src; /* Source information for list element. */ | |
| 690 | int length; /* Number of bytes in src, or -1. */ | |
| 691 | char *dst; /* Place to put list-ified element. */ | |
| 692 | int flags; /* Flags produced by Tcl_ScanElement. */ | |
| 693 | { | |
| 694 | register char *p = dst; | |
| 695 | register CONST char *lastChar; | |
| 696 | ||
| 697 | /* | |
| 698 | * See the comment block at the beginning of the Tcl_ScanElement | |
| 699 | * code for details of how this works. | |
| 700 | */ | |
| 701 | ||
| 702 | if (src && length == -1) { | |
| 703 | length = strlen(src); | |
| 704 | } | |
| 705 | if ((src == NULL) || (length == 0)) { | |
| 706 | p[0] = '{'; | |
| 707 | p[1] = '}'; | |
| 708 | p[2] = 0; | |
| 709 | return 2; | |
| 710 | } | |
| 711 | lastChar = src + length; | |
| 712 | if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { | |
| 713 | *p = '{'; | |
| 714 | p++; | |
| 715 | for ( ; src != lastChar; src++, p++) { | |
| 716 | *p = *src; | |
| 717 | } | |
| 718 | *p = '}'; | |
| 719 | p++; | |
| 720 | } else { | |
| 721 | if (*src == '{') { | |
| 722 | /* | |
| 723 | * Can't have a leading brace unless the whole element is | |
| 724 | * enclosed in braces. Add a backslash before the brace. | |
| 725 | * Furthermore, this may destroy the balance between open | |
| 726 | * and close braces, so set BRACES_UNMATCHED. | |
| 727 | */ | |
| 728 | ||
| 729 | p[0] = '\\'; | |
| 730 | p[1] = '{'; | |
| 731 | p += 2; | |
| 732 | src++; | |
| 733 | flags |= BRACES_UNMATCHED; | |
| 734 | } | |
| 735 | for (; src != lastChar; src++) { | |
| 736 | switch (*src) { | |
| 737 | case ']': | |
| 738 | case '[': | |
| 739 | case '$': | |
| 740 | case ';': | |
| 741 | case ' ': | |
| 742 | case '\\': | |
| 743 | case '"': | |
| 744 | *p = '\\'; | |
| 745 | p++; | |
| 746 | break; | |
| 747 | case '{': | |
| 748 | case '}': | |
| 749 | /* | |
| 750 | * It may not seem necessary to backslash braces, but | |
| 751 | * it is. The reason for this is that the resulting | |
| 752 | * list element may actually be an element of a sub-list | |
| 753 | * enclosed in braces (e.g. if Tcl_DStringStartSublist | |
| 754 | * has been invoked), so there may be a brace mismatch | |
| 755 | * if the braces aren't backslashed. | |
| 756 | */ | |
| 757 | ||
| 758 | if (flags & BRACES_UNMATCHED) { | |
| 759 | *p = '\\'; | |
| 760 | p++; | |
| 761 | } | |
| 762 | break; | |
| 763 | case '\f': | |
| 764 | *p = '\\'; | |
| 765 | p++; | |
| 766 | *p = 'f'; | |
| 767 | p++; | |
| 768 | continue; | |
| 769 | case '\n': | |
| 770 | *p = '\\'; | |
| 771 | p++; | |
| 772 | *p = 'n'; | |
| 773 | p++; | |
| 774 | continue; | |
| 775 | case '\r': | |
| 776 | *p = '\\'; | |
| 777 | p++; | |
| 778 | *p = 'r'; | |
| 779 | p++; | |
| 780 | continue; | |
| 781 | case '\t': | |
| 782 | *p = '\\'; | |
| 783 | p++; | |
| 784 | *p = 't'; | |
| 785 | p++; | |
| 786 | continue; | |
| 787 | case '\v': | |
| 788 | *p = '\\'; | |
| 789 | p++; | |
| 790 | *p = 'v'; | |
| 791 | p++; | |
| 792 | continue; | |
| 793 | } | |
| 794 | *p = *src; | |
| 795 | p++; | |
| 796 | } | |
| 797 | } | |
| 798 | *p = '\0'; | |
| 799 | return p-dst; | |
| 800 | } | |
| 801 | ||
| 802 | /* | |
| 803 | *---------------------------------------------------------------------- | |
| 804 | * | |
| 805 | * Tcl_Merge -- | |
| 806 | * | |
| 807 | * Given a collection of strings, merge them together into a | |
| 808 | * single string that has proper Tcl list structured (i.e. | |
| 809 | * Tcl_SplitList may be used to retrieve strings equal to the | |
| 810 | * original elements, and Tcl_Eval will parse the string back | |
| 811 | * into its original elements). | |
| 812 | * | |
| 813 | * Results: | |
| 814 | * The return value is the address of a dynamically-allocated | |
| 815 | * string containing the merged list. | |
| 816 | * | |
| 817 | * Side effects: | |
| 818 | * None. | |
| 819 | * | |
| 820 | *---------------------------------------------------------------------- | |
| 821 | */ | |
| 822 | ||
| 823 | char * | |
| 824 | Tcl_Merge(argc, argv) | |
| 825 | int argc; /* How many strings to merge. */ | |
| 826 | char **argv; /* Array of string values. */ | |
| 827 | { | |
| 828 | # define LOCAL_SIZE 20 | |
| 829 | int localFlags[LOCAL_SIZE], *flagPtr; | |
| 830 | int numChars; | |
| 831 | char *result; | |
| 832 | char *dst; | |
| 833 | int i; | |
| 834 | ||
| 835 | /* | |
| 836 | * Pass 1: estimate space, gather flags. | |
| 837 | */ | |
| 838 | ||
| 839 | if (argc <= LOCAL_SIZE) { | |
| 840 | flagPtr = localFlags; | |
| 841 | } else { | |
| 842 | flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); | |
| 843 | } | |
| 844 | numChars = 1; | |
| 845 | for (i = 0; i < argc; i++) { | |
| 846 | numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; | |
| 847 | } | |
| 848 | ||
| 849 | /* | |
| 850 | * Pass two: copy into the result area. | |
| 851 | */ | |
| 852 | ||
| 853 | result = (char *) ckalloc((unsigned) numChars); | |
| 854 | dst = result; | |
| 855 | for (i = 0; i < argc; i++) { | |
| 856 | numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); | |
| 857 | dst += numChars; | |
| 858 | *dst = ' '; | |
| 859 | dst++; | |
| 860 | } | |
| 861 | if (dst == result) { | |
| 862 | *dst = 0; | |
| 863 | } else { | |
| 864 | dst[-1] = 0; | |
| 865 | } | |
| 866 | ||
| 867 | if (flagPtr != localFlags) { | |
| 868 | ckfree((char *) flagPtr); | |
| 869 | } | |
| 870 | return result; | |
| 871 | } | |
| 872 | ||
| 873 | /* | |
| 874 | *---------------------------------------------------------------------- | |
| 875 | * | |
| 876 | * Tcl_Backslash -- | |
| 877 | * | |
| 878 | * Figure out how to handle a backslash sequence. | |
| 879 | * | |
| 880 | * Results: | |
| 881 | * The return value is the character that should be substituted | |
| 882 | * in place of the backslash sequence that starts at src. If | |
| 883 | * readPtr isn't NULL then it is filled in with a count of the | |
| 884 | * number of characters in the backslash sequence. | |
| 885 | * | |
| 886 | * Side effects: | |
| 887 | * None. | |
| 888 | * | |
| 889 | *---------------------------------------------------------------------- | |
| 890 | */ | |
| 891 | ||
| 892 | char | |
| 893 | Tcl_Backslash(src, readPtr) | |
| 894 | CONST char *src; /* Points to the backslash character of | |
| 895 | * a backslash sequence. */ | |
| 896 | int *readPtr; /* Fill in with number of characters read | |
| 897 | * from src, unless NULL. */ | |
| 898 | { | |
| 899 | char buf[TCL_UTF_MAX]; | |
| 900 | Tcl_UniChar ch; | |
| 901 | ||
| 902 | Tcl_UtfBackslash(src, readPtr, buf); | |
| 903 | Tcl_UtfToUniChar(buf, &ch); | |
| 904 | return (char) ch; | |
| 905 | } | |
| 906 | ||
| 907 | /* | |
| 908 | *---------------------------------------------------------------------- | |
| 909 | * | |
| 910 | * Tcl_Concat -- | |
| 911 | * | |
| 912 | * Concatenate a set of strings into a single large string. | |
| 913 | * | |
| 914 | * Results: | |
| 915 | * The return value is dynamically-allocated string containing | |
| 916 | * a concatenation of all the strings in argv, with spaces between | |
| 917 | * the original argv elements. | |
| 918 | * | |
| 919 | * Side effects: | |
| 920 | * Memory is allocated for the result; the caller is responsible | |
| 921 | * for freeing the memory. | |
| 922 | * | |
| 923 | *---------------------------------------------------------------------- | |
| 924 | */ | |
| 925 | ||
| 926 | char * | |
| 927 | Tcl_Concat(argc, argv) | |
| 928 | int argc; /* Number of strings to concatenate. */ | |
| 929 | char **argv; /* Array of strings to concatenate. */ | |
| 930 | { | |
| 931 | int totalSize, i; | |
| 932 | char *p; | |
| 933 | char *result; | |
| 934 | ||
| 935 | for (totalSize = 1, i = 0; i < argc; i++) { | |
| 936 | totalSize += strlen(argv[i]) + 1; | |
| 937 | } | |
| 938 | result = (char *) ckalloc((unsigned) totalSize); | |
| 939 | if (argc == 0) { | |
| 940 | *result = '\0'; | |
| 941 | return result; | |
| 942 | } | |
| 943 | for (p = result, i = 0; i < argc; i++) { | |
| 944 | char *element; | |
| 945 | int length; | |
| 946 | ||
| 947 | /* | |
| 948 | * Clip white space off the front and back of the string | |
| 949 | * to generate a neater result, and ignore any empty | |
| 950 | * elements. | |
| 951 | */ | |
| 952 | ||
| 953 | element = argv[i]; | |
| 954 | while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ | |
| 955 | element++; | |
| 956 | } | |
| 957 | for (length = strlen(element); | |
| 958 | (length > 0) | |
| 959 | && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ | |
| 960 | && ((length < 2) || (element[length-2] != '\\')); | |
| 961 | length--) { | |
| 962 | /* Null loop body. */ | |
| 963 | } | |
| 964 | if (length == 0) { | |
| 965 | continue; | |
| 966 | } | |
| 967 | memcpy((VOID *) p, (VOID *) element, (size_t) length); | |
| 968 | p += length; | |
| 969 | *p = ' '; | |
| 970 | p++; | |
| 971 | } | |
| 972 | if (p != result) { | |
| 973 | p[-1] = 0; | |
| 974 | } else { | |
| 975 | *p = 0; | |
| 976 | } | |
| 977 | return result; | |
| 978 | } | |
| 979 | ||
| 980 | /* | |
| 981 | *---------------------------------------------------------------------- | |
| 982 | * | |
| 983 | * Tcl_ConcatObj -- | |
| 984 | * | |
| 985 | * Concatenate the strings from a set of objects into a single string | |
| 986 | * object with spaces between the original strings. | |
| 987 | * | |
| 988 | * Results: | |
| 989 | * The return value is a new string object containing a concatenation | |
| 990 | * of the strings in objv. Its ref count is zero. | |
| 991 | * | |
| 992 | * Side effects: | |
| 993 | * A new object is created. | |
| 994 | * | |
| 995 | *---------------------------------------------------------------------- | |
| 996 | */ | |
| 997 | ||
| 998 | Tcl_Obj * | |
| 999 | Tcl_ConcatObj(objc, objv) | |
| 1000 | int objc; /* Number of objects to concatenate. */ | |
| 1001 | Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ | |
| 1002 | { | |
| 1003 | int allocSize, finalSize, length, elemLength, i; | |
| 1004 | char *p; | |
| 1005 | char *element; | |
| 1006 | char *concatStr; | |
| 1007 | Tcl_Obj *objPtr; | |
| 1008 | ||
| 1009 | /* | |
| 1010 | * Check first to see if all the items are of list type. If so, | |
| 1011 | * we will concat them together as lists, and return a list object. | |
| 1012 | * This is only valid when the lists have no current string | |
| 1013 | * representation, since we don't know what the original type was. | |
| 1014 | * An original string rep may have lost some whitespace info when | |
| 1015 | * converted which could be important. | |
| 1016 | */ | |
| 1017 | for (i = 0; i < objc; i++) { | |
| 1018 | objPtr = objv[i]; | |
| 1019 | if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { | |
| 1020 | break; | |
| 1021 | } | |
| 1022 | } | |
| 1023 | if (i == objc) { | |
| 1024 | Tcl_Obj **listv; | |
| 1025 | int listc; | |
| 1026 | ||
| 1027 | objPtr = Tcl_NewListObj(0, NULL); | |
| 1028 | for (i = 0; i < objc; i++) { | |
| 1029 | /* | |
| 1030 | * Tcl_ListObjAppendList could be used here, but this saves | |
| 1031 | * us a bit of type checking (since we've already done it) | |
| 1032 | * Use of INT_MAX tells us to always put the new stuff on | |
| 1033 | * the end. It will be set right in Tcl_ListObjReplace. | |
| 1034 | */ | |
| 1035 | Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); | |
| 1036 | Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); | |
| 1037 | } | |
| 1038 | return objPtr; | |
| 1039 | } | |
| 1040 | ||
| 1041 | allocSize = 0; | |
| 1042 | for (i = 0; i < objc; i++) { | |
| 1043 | objPtr = objv[i]; | |
| 1044 | element = Tcl_GetStringFromObj(objPtr, &length); | |
| 1045 | if ((element != NULL) && (length > 0)) { | |
| 1046 | allocSize += (length + 1); | |
| 1047 | } | |
| 1048 | } | |
| 1049 | if (allocSize == 0) { | |
| 1050 | allocSize = 1; /* enough for the NULL byte at end */ | |
| 1051 | } | |
| 1052 | ||
| 1053 | /* | |
| 1054 | * Allocate storage for the concatenated result. Note that allocSize | |
| 1055 | * is one more than the total number of characters, and so includes | |
| 1056 | * room for the terminating NULL byte. | |
| 1057 | */ | |
| 1058 | ||
| 1059 | concatStr = (char *) ckalloc((unsigned) allocSize); | |
| 1060 | ||
| 1061 | /* | |
| 1062 | * Now concatenate the elements. Clip white space off the front and back | |
| 1063 | * to generate a neater result, and ignore any empty elements. Also put | |
| 1064 | * a null byte at the end. | |
| 1065 | */ | |
| 1066 | ||
| 1067 | finalSize = 0; | |
| 1068 | if (objc == 0) { | |
| 1069 | *concatStr = '\0'; | |
| 1070 | } else { | |
| 1071 | p = concatStr; | |
| 1072 | for (i = 0; i < objc; i++) { | |
| 1073 | objPtr = objv[i]; | |
| 1074 | element = Tcl_GetStringFromObj(objPtr, &elemLength); | |
| 1075 | while ((elemLength > 0) | |
| 1076 | && (isspace(UCHAR(*element)))) { /* INTL: ISO space. */ | |
| 1077 | element++; | |
| 1078 | elemLength--; | |
| 1079 | } | |
| 1080 | ||
| 1081 | /* | |
| 1082 | * Trim trailing white space. But, be careful not to trim | |
| 1083 | * a space character if it is preceded by a backslash: in | |
| 1084 | * this case it could be significant. | |
| 1085 | */ | |
| 1086 | ||
| 1087 | while ((elemLength > 0) | |
| 1088 | && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO space. */ | |
| 1089 | && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { | |
| 1090 | elemLength--; | |
| 1091 | } | |
| 1092 | if (elemLength == 0) { | |
| 1093 | continue; /* nothing left of this element */ | |
| 1094 | } | |
| 1095 | memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); | |
| 1096 | p += elemLength; | |
| 1097 | *p = ' '; | |
| 1098 | p++; | |
| 1099 | finalSize += (elemLength + 1); | |
| 1100 | } | |
| 1101 | if (p != concatStr) { | |
| 1102 | p[-1] = 0; | |
| 1103 | finalSize -= 1; /* we overwrote the final ' ' */ | |
| 1104 | } else { | |
| 1105 | *p = 0; | |
| 1106 | } | |
| 1107 | } | |
| 1108 | ||
| 1109 | TclNewObj(objPtr); | |
| 1110 | objPtr->bytes = concatStr; | |
| 1111 | objPtr->length = finalSize; | |
| 1112 | return objPtr; | |
| 1113 | } | |
| 1114 | ||
| 1115 | /* | |
| 1116 | *---------------------------------------------------------------------- | |
| 1117 | * | |
| 1118 | * Tcl_StringMatch -- | |
| 1119 | * | |
| 1120 | * See if a particular string matches a particular pattern. | |
| 1121 | * | |
| 1122 | * Results: | |
| 1123 | * The return value is 1 if string matches pattern, and | |
| 1124 | * 0 otherwise. The matching operation permits the following | |
| 1125 | * special characters in the pattern: *?\[] (see the manual | |
| 1126 | * entry for details on what these mean). | |
| 1127 | * | |
| 1128 | * Side effects: | |
| 1129 | * None. | |
| 1130 | * | |
| 1131 | *---------------------------------------------------------------------- | |
| 1132 | */ | |
| 1133 | ||
| 1134 | int | |
| 1135 | Tcl_StringMatch(string, pattern) | |
| 1136 | CONST char *string; /* String. */ | |
| 1137 | CONST char *pattern; /* Pattern, which may contain special | |
| 1138 | * characters. */ | |
| 1139 | { | |
| 1140 | int p, s; | |
| 1141 | CONST char *pstart = pattern; | |
| 1142 | ||
| 1143 | while (1) { | |
| 1144 | p = *pattern; | |
| 1145 | s = *string; | |
| 1146 | ||
| 1147 | /* | |
| 1148 | * See if we're at the end of both the pattern and the string. If | |
| 1149 | * so, we succeeded. If we're at the end of the pattern but not at | |
| 1150 | * the end of the string, we failed. | |
| 1151 | */ | |
| 1152 | ||
| 1153 | if (p == '\0') { | |
| 1154 | if (s == '\0') { | |
| 1155 | return 1; | |
| 1156 | } else { | |
| 1157 | return 0; | |
| 1158 | } | |
| 1159 | } | |
| 1160 | if ((s == '\0') && (p != '*')) { | |
| 1161 | return 0; | |
| 1162 | } | |
| 1163 | ||
| 1164 | /* Check for a "*" as the next pattern character. It matches | |
| 1165 | * any substring. We handle this by calling ourselves | |
| 1166 | * recursively for each postfix of string, until either we | |
| 1167 | * match or we reach the end of the string. | |
| 1168 | */ | |
| 1169 | ||
| 1170 | if (p == '*') { | |
| 1171 | pattern++; | |
| 1172 | if (*pattern == '\0') { | |
| 1173 | return 1; | |
| 1174 | } | |
| 1175 | while (1) { | |
| 1176 | if (Tcl_StringMatch(string, pattern)) { | |
| 1177 | return 1; | |
| 1178 | } | |
| 1179 | if (*string == '\0') { | |
| 1180 | return 0; | |
| 1181 | } | |
| 1182 | string++; | |
| 1183 | } | |
| 1184 | } | |
| 1185 | ||
| 1186 | /* Check for a "?" as the next pattern character. It matches | |
| 1187 | * any single character. | |
| 1188 | */ | |
| 1189 | ||
| 1190 | if (p == '?') { | |
| 1191 | Tcl_UniChar ch; | |
| 1192 | ||
| 1193 | pattern++; | |
| 1194 | string += Tcl_UtfToUniChar(string, &ch); | |
| 1195 | continue; | |
| 1196 | } | |
| 1197 | ||
| 1198 | /* Check for a "[" as the next pattern character. It is followed | |
| 1199 | * by a list of characters that are acceptable, or by a range | |
| 1200 | * (two characters separated by "-"). | |
| 1201 | */ | |
| 1202 | ||
| 1203 | if (p == '[') { | |
| 1204 | Tcl_UniChar ch, startChar, endChar; | |
| 1205 | ||
| 1206 | pattern++; | |
| 1207 | string += Tcl_UtfToUniChar(string, &ch); | |
| 1208 | ||
| 1209 | while (1) { | |
| 1210 | if ((*pattern == ']') || (*pattern == '\0')) { | |
| 1211 | return 0; | |
| 1212 | } | |
| 1213 | pattern += Tcl_UtfToUniChar(pattern, &startChar); | |
| 1214 | if (*pattern == '-') { | |
| 1215 | pattern++; | |
| 1216 | if (*pattern == '\0') { | |
| 1217 | return 0; | |
| 1218 | } | |
| 1219 | pattern += Tcl_UtfToUniChar(pattern, &endChar); | |
| 1220 | if (((startChar <= ch) && (ch <= endChar)) | |
| 1221 | || ((endChar <= ch) && (ch <= startChar))) { | |
| 1222 | /* | |
| 1223 | * Matches ranges of form [a-z] or [z-a]. | |
| 1224 | */ | |
| 1225 | ||
| 1226 | break; | |
| 1227 | } | |
| 1228 | } else if (startChar == ch) { | |
| 1229 | break; | |
| 1230 | } | |
| 1231 | } | |
| 1232 | while (*pattern != ']') { | |
| 1233 | if (*pattern == '\0') { | |
| 1234 | pattern = Tcl_UtfPrev(pattern, pstart); | |
| 1235 | break; | |
| 1236 | } | |
| 1237 | pattern++; | |
| 1238 | } | |
| 1239 | pattern++; | |
| 1240 | continue; | |
| 1241 | } | |
| 1242 | ||
| 1243 | /* If the next pattern character is '\', just strip off the '\' | |
| 1244 | * so we do exact matching on the character that follows. | |
| 1245 | */ | |
| 1246 | ||
| 1247 | if (p == '\\') { | |
| 1248 | pattern++; | |
| 1249 | p = *pattern; | |
| 1250 | if (p == '\0') { | |
| 1251 | return 0; | |
| 1252 | } | |
| 1253 | } | |
| 1254 | ||
| 1255 | /* There's no special character. Just make sure that the next | |
| 1256 | * bytes of each string match. | |
| 1257 | */ | |
| 1258 | ||
| 1259 | if (s != p) { | |
| 1260 | return 0; | |
| 1261 | } | |
| 1262 | pattern++; | |
| 1263 | string++; | |
| 1264 | } | |
| 1265 | } | |
| 1266 | ||
| 1267 | /* | |
| 1268 | *---------------------------------------------------------------------- | |
| 1269 | * | |
| 1270 | * Tcl_StringCaseMatch -- | |
| 1271 | * | |
| 1272 | * See if a particular string matches a particular pattern. | |
| 1273 | * Allows case insensitivity. | |
| 1274 | * | |
| 1275 | * Results: | |
| 1276 | * The return value is 1 if string matches pattern, and | |
| 1277 | * 0 otherwise. The matching operation permits the following | |
| 1278 | * special characters in the pattern: *?\[] (see the manual | |
| 1279 | * entry for details on what these mean). | |
| 1280 | * | |
| 1281 | * Side effects: | |
| 1282 | * None. | |
| 1283 | * | |
| 1284 | *---------------------------------------------------------------------- | |
| 1285 | */ | |
| 1286 | ||
| 1287 | int | |
| 1288 | Tcl_StringCaseMatch(string, pattern, nocase) | |
| 1289 | CONST char *string; /* String. */ | |
| 1290 | CONST char *pattern; /* Pattern, which may contain special | |
| 1291 | * characters. */ | |
| 1292 | int nocase; /* 0 for case sensitive, 1 for insensitive */ | |
| 1293 | { | |
| 1294 | int p, s; | |
| 1295 | CONST char *pstart = pattern; | |
| 1296 | Tcl_UniChar ch1, ch2; | |
| 1297 | ||
| 1298 | while (1) { | |
| 1299 | p = *pattern; | |
| 1300 | s = *string; | |
| 1301 | ||
| 1302 | /* | |
| 1303 | * See if we're at the end of both the pattern and the string. If | |
| 1304 | * so, we succeeded. If we're at the end of the pattern but not at | |
| 1305 | * the end of the string, we failed. | |
| 1306 | */ | |
| 1307 | ||
| 1308 | if (p == '\0') { | |
| 1309 | return (s == '\0'); | |
| 1310 | } | |
| 1311 | if ((s == '\0') && (p != '*')) { | |
| 1312 | return 0; | |
| 1313 | } | |
| 1314 | ||
| 1315 | /* Check for a "*" as the next pattern character. It matches | |
| 1316 | * any substring. We handle this by calling ourselves | |
| 1317 | * recursively for each postfix of string, until either we | |
| 1318 | * match or we reach the end of the string. | |
| 1319 | */ | |
| 1320 | ||
| 1321 | if (p == '*') { | |
| 1322 | pattern++; | |
| 1323 | if (*pattern == '\0') { | |
| 1324 | return 1; | |
| 1325 | } | |
| 1326 | while (1) { | |
| 1327 | if (Tcl_StringCaseMatch(string, pattern, nocase)) { | |
| 1328 | return 1; | |
| 1329 | } | |
| 1330 | if (*string == '\0') { | |
| 1331 | return 0; | |
| 1332 | } | |
| 1333 | string++; | |
| 1334 | } | |
| 1335 | } | |
| 1336 | ||
| 1337 | /* Check for a "?" as the next pattern character. It matches | |
| 1338 | * any single character. | |
| 1339 | */ | |
| 1340 | ||
| 1341 | if (p == '?') { | |
| 1342 | pattern++; | |
| 1343 | string += Tcl_UtfToUniChar(string, &ch1); | |
| 1344 | continue; | |
| 1345 | } | |
| 1346 | ||
| 1347 | /* Check for a "[" as the next pattern character. It is followed | |
| 1348 | * by a list of characters that are acceptable, or by a range | |
| 1349 | * (two characters separated by "-"). | |
| 1350 | */ | |
| 1351 | ||
| 1352 | if (p == '[') { | |
| 1353 | Tcl_UniChar startChar, endChar; | |
| 1354 | ||
| 1355 | pattern++; | |
| 1356 | string += Tcl_UtfToUniChar(string, &ch1); | |
| 1357 | if (nocase) { | |
| 1358 | ch1 = Tcl_UniCharToLower(ch1); | |
| 1359 | } | |
| 1360 | while (1) { | |
| 1361 | if ((*pattern == ']') || (*pattern == '\0')) { | |
| 1362 | return 0; | |
| 1363 | } | |
| 1364 | pattern += Tcl_UtfToUniChar(pattern, &startChar); | |
| 1365 | if (nocase) { | |
| 1366 | startChar = Tcl_UniCharToLower(startChar); | |
| 1367 | } | |
| 1368 | if (*pattern == '-') { | |
| 1369 | pattern++; | |
| 1370 | if (*pattern == '\0') { | |
| 1371 | return 0; | |
| 1372 | } | |
| 1373 | pattern += Tcl_UtfToUniChar(pattern, &endChar); | |
| 1374 | if (nocase) { | |
| 1375 | endChar = Tcl_UniCharToLower(endChar); | |
| 1376 | } | |
| 1377 | if (((startChar <= ch1) && (ch1 <= endChar)) | |
| 1378 | || ((endChar <= ch1) && (ch1 <= startChar))) { | |
| 1379 | /* | |
| 1380 | * Matches ranges of form [a-z] or [z-a]. | |
| 1381 | */ | |
| 1382 | ||
| 1383 | break; | |
| 1384 | } | |
| 1385 | } else if (startChar == ch1) { | |
| 1386 | break; | |
| 1387 | } | |
| 1388 | } | |
| 1389 | while (*pattern != ']') { | |
| 1390 | if (*pattern == '\0') { | |
| 1391 | pattern = Tcl_UtfPrev(pattern, pstart); | |
| 1392 | break; | |
| 1393 | } | |
| 1394 | pattern++; | |
| 1395 | } | |
| 1396 | pattern++; | |
| 1397 | continue; | |
| 1398 | } | |
| 1399 | ||
| 1400 | /* If the next pattern character is '\', just strip off the '\' | |
| 1401 | * so we do exact matching on the character that follows. | |
| 1402 | */ | |
| 1403 | ||
| 1404 | if (p == '\\') { | |
| 1405 | pattern++; | |
| 1406 | p = *pattern; | |
| 1407 | if (p == '\0') { | |
| 1408 | return 0; | |
| 1409 | } | |
| 1410 | } | |
| 1411 | ||
| 1412 | /* There's no special character. Just make sure that the next | |
| 1413 | * bytes of each string match. | |
| 1414 | */ | |
| 1415 | ||
| 1416 | string += Tcl_UtfToUniChar(string, &ch1); | |
| 1417 | pattern += Tcl_UtfToUniChar(pattern, &ch2); | |
| 1418 | if (nocase) { | |
| 1419 | if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { | |
| 1420 | return 0; | |
| 1421 | } | |
| 1422 | } else if (ch1 != ch2) { | |
| 1423 | return 0; | |
| 1424 | } | |
| 1425 | } | |
| 1426 | } | |
| 1427 | ||
| 1428 | /* | |
| 1429 | *---------------------------------------------------------------------- | |
| 1430 | * | |
| 1431 | * Tcl_DStringInit -- | |
| 1432 | * | |
| 1433 | * Initializes a dynamic string, discarding any previous contents | |
| 1434 | * of the string (Tcl_DStringFree should have been called already | |
| 1435 | * if the dynamic string was previously in use). | |
| 1436 | * | |
| 1437 | * Results: | |
| 1438 | * None. | |
| 1439 | * | |
| 1440 | * Side effects: | |
| 1441 | * The dynamic string is initialized to be empty. | |
| 1442 | * | |
| 1443 | *---------------------------------------------------------------------- | |
| 1444 | */ | |
| 1445 | ||
| 1446 | void | |
| 1447 | Tcl_DStringInit(dsPtr) | |
| 1448 | Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ | |
| 1449 | { | |
| 1450 | dsPtr->string = dsPtr->staticSpace; | |
| 1451 | dsPtr->length = 0; | |
| 1452 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; | |
| 1453 | dsPtr->staticSpace[0] = '\0'; | |
| 1454 | } | |
| 1455 | ||
| 1456 | /* | |
| 1457 | *---------------------------------------------------------------------- | |
| 1458 | * | |
| 1459 | * Tcl_DStringAppend -- | |
| 1460 | * | |
| 1461 | * Append more characters to the current value of a dynamic string. | |
| 1462 | * | |
| 1463 | * Results: | |
| 1464 | * The return value is a pointer to the dynamic string's new value. | |
| 1465 | * | |
| 1466 | * Side effects: | |
| 1467 | * Length bytes from string (or all of string if length is less | |
| 1468 | * than zero) are added to the current value of the string. Memory | |
| 1469 | * gets reallocated if needed to accomodate the string's new size. | |
| 1470 | * | |
| 1471 | *---------------------------------------------------------------------- | |
| 1472 | */ | |
| 1473 | ||
| 1474 | char * | |
| 1475 | Tcl_DStringAppend(dsPtr, string, length) | |
| 1476 | Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | |
| 1477 | CONST char *string; /* String to append. If length is -1 then | |
| 1478 | * this must be null-terminated. */ | |
| 1479 | int length; /* Number of characters from string to | |
| 1480 | * append. If < 0, then append all of string, | |
| 1481 | * up to null at end. */ | |
| 1482 | { | |
| 1483 | int newSize; | |
| 1484 | char *dst; | |
| 1485 | CONST char *end; | |
| 1486 | ||
| 1487 | if (length < 0) { | |
| 1488 | length = strlen(string); | |
| 1489 | } | |
| 1490 | newSize = length + dsPtr->length; | |
| 1491 | ||
| 1492 | /* | |
| 1493 | * Allocate a larger buffer for the string if the current one isn't | |
| 1494 | * large enough. Allocate extra space in the new buffer so that there | |
| 1495 | * will be room to grow before we have to allocate again. | |
| 1496 | */ | |
| 1497 | ||
| 1498 | if (newSize >= dsPtr->spaceAvl) { | |
| 1499 | dsPtr->spaceAvl = newSize * 2; | |
| 1500 | if (dsPtr->string == dsPtr->staticSpace) { | |
| 1501 | char *newString; | |
| 1502 | ||
| 1503 | newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | |
| 1504 | memcpy((VOID *) newString, (VOID *) dsPtr->string, | |
| 1505 | (size_t) dsPtr->length); | |
| 1506 | dsPtr->string = newString; | |
| 1507 | } else { | |
| 1508 | dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | |
| 1509 | (size_t) dsPtr->spaceAvl); | |
| 1510 | } | |
| 1511 | } | |
| 1512 | ||
| 1513 | /* | |
| 1514 | * Copy the new string into the buffer at the end of the old | |
| 1515 | * one. | |
| 1516 | */ | |
| 1517 | ||
| 1518 | for (dst = dsPtr->string + dsPtr->length, end = string+length; | |
| 1519 | string < end; string++, dst++) { | |
| 1520 | *dst = *string; | |
| 1521 | } | |
| 1522 | *dst = '\0'; | |
| 1523 | dsPtr->length += length; | |
| 1524 | return dsPtr->string; | |
| 1525 | } | |
| 1526 | ||
| 1527 | /* | |
| 1528 | *---------------------------------------------------------------------- | |
| 1529 | * | |
| 1530 | * Tcl_DStringAppendElement -- | |
| 1531 | * | |
| 1532 | * Append a list element to the current value of a dynamic string. | |
| 1533 | * | |
| 1534 | * Results: | |
| 1535 | * The return value is a pointer to the dynamic string's new value. | |
| 1536 | * | |
| 1537 | * Side effects: | |
| 1538 | * String is reformatted as a list element and added to the current | |
| 1539 | * value of the string. Memory gets reallocated if needed to | |
| 1540 | * accomodate the string's new size. | |
| 1541 | * | |
| 1542 | *---------------------------------------------------------------------- | |
| 1543 | */ | |
| 1544 | ||
| 1545 | char * | |
| 1546 | Tcl_DStringAppendElement(dsPtr, string) | |
| 1547 | Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | |
| 1548 | CONST char *string; /* String to append. Must be | |
| 1549 | * null-terminated. */ | |
| 1550 | { | |
| 1551 | int newSize, flags; | |
| 1552 | char *dst; | |
| 1553 | ||
| 1554 | newSize = Tcl_ScanElement(string, &flags) + dsPtr->length + 1; | |
| 1555 | ||
| 1556 | /* | |
| 1557 | * Allocate a larger buffer for the string if the current one isn't | |
| 1558 | * large enough. Allocate extra space in the new buffer so that there | |
| 1559 | * will be room to grow before we have to allocate again. | |
| 1560 | * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string | |
| 1561 | * to a larger buffer, since there may be embedded NULLs in the | |
| 1562 | * string in some cases. | |
| 1563 | */ | |
| 1564 | ||
| 1565 | if (newSize >= dsPtr->spaceAvl) { | |
| 1566 | dsPtr->spaceAvl = newSize * 2; | |
| 1567 | if (dsPtr->string == dsPtr->staticSpace) { | |
| 1568 | char *newString; | |
| 1569 | ||
| 1570 | newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | |
| 1571 | memcpy((VOID *) newString, (VOID *) dsPtr->string, | |
| 1572 | (size_t) dsPtr->length); | |
| 1573 | dsPtr->string = newString; | |
| 1574 | } else { | |
| 1575 | dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | |
| 1576 | (size_t) dsPtr->spaceAvl); | |
| 1577 | } | |
| 1578 | } | |
| 1579 | ||
| 1580 | /* | |
| 1581 | * Convert the new string to a list element and copy it into the | |
| 1582 | * buffer at the end, with a space, if needed. | |
| 1583 | */ | |
| 1584 | ||
| 1585 | dst = dsPtr->string + dsPtr->length; | |
| 1586 | if (TclNeedSpace(dsPtr->string, dst)) { | |
| 1587 | *dst = ' '; | |
| 1588 | dst++; | |
| 1589 | dsPtr->length++; | |
| 1590 | } | |
| 1591 | dsPtr->length += Tcl_ConvertElement(string, dst, flags); | |
| 1592 | return dsPtr->string; | |
| 1593 | } | |
| 1594 | ||
| 1595 | /* | |
| 1596 | *---------------------------------------------------------------------- | |
| 1597 | * | |
| 1598 | * Tcl_DStringSetLength -- | |
| 1599 | * | |
| 1600 | * Change the length of a dynamic string. This can cause the | |
| 1601 | * string to either grow or shrink, depending on the value of | |
| 1602 | * length. | |
| 1603 | * | |
| 1604 | * Results: | |
| 1605 | * None. | |
| 1606 | * | |
| 1607 | * Side effects: | |
| 1608 | * The length of dsPtr is changed to length and a null byte is | |
| 1609 | * stored at that position in the string. If length is larger | |
| 1610 | * than the space allocated for dsPtr, then a panic occurs. | |
| 1611 | * | |
| 1612 | *---------------------------------------------------------------------- | |
| 1613 | */ | |
| 1614 | ||
| 1615 | void | |
| 1616 | Tcl_DStringSetLength(dsPtr, length) | |
| 1617 | Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | |
| 1618 | int length; /* New length for dynamic string. */ | |
| 1619 | { | |
| 1620 | int newsize; | |
| 1621 | ||
| 1622 | if (length < 0) { | |
| 1623 | length = 0; | |
| 1624 | } | |
| 1625 | if (length >= dsPtr->spaceAvl) { | |
| 1626 | /* | |
| 1627 | * There are two interesting cases here. In the first case, the user | |
| 1628 | * may be trying to allocate a large buffer of a specific size. It | |
| 1629 | * would be wasteful to overallocate that buffer, so we just allocate | |
| 1630 | * enough for the requested size plus the trailing null byte. In the | |
| 1631 | * second case, we are growing the buffer incrementally, so we need | |
| 1632 | * behavior similar to Tcl_DStringAppend. The requested length will | |
| 1633 | * usually be a small delta above the current spaceAvl, so we'll end up | |
| 1634 | * doubling the old size. This won't grow the buffer quite as quickly, | |
| 1635 | * but it should be close enough. | |
| 1636 | */ | |
| 1637 | ||
| 1638 | newsize = dsPtr->spaceAvl * 2; | |
| 1639 | if (length < newsize) { | |
| 1640 | dsPtr->spaceAvl = newsize; | |
| 1641 | } else { | |
| 1642 | dsPtr->spaceAvl = length + 1; | |
| 1643 | } | |
| 1644 | if (dsPtr->string == dsPtr->staticSpace) { | |
| 1645 | char *newString; | |
| 1646 | ||
| 1647 | newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); | |
| 1648 | memcpy((VOID *) newString, (VOID *) dsPtr->string, | |
| 1649 | (size_t) dsPtr->length); | |
| 1650 | dsPtr->string = newString; | |
| 1651 | } else { | |
| 1652 | dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, | |
| 1653 | (size_t) dsPtr->spaceAvl); | |
| 1654 | } | |
| 1655 | } | |
| 1656 | dsPtr->length = length; | |
| 1657 | dsPtr->string[length] = 0; | |
| 1658 | } | |
| 1659 | ||
| 1660 | /* | |
| 1661 | *---------------------------------------------------------------------- | |
| 1662 | * | |
| 1663 | * Tcl_DStringFree -- | |
| 1664 | * | |
| 1665 | * Frees up any memory allocated for the dynamic string and | |
| 1666 | * reinitializes the string to an empty state. | |
| 1667 | * | |
| 1668 | * Results: | |
| 1669 | * None. | |
| 1670 | * | |
| 1671 | * Side effects: | |
| 1672 | * The previous contents of the dynamic string are lost, and | |
| 1673 | * the new value is an empty string. | |
| 1674 | * | |
| 1675 | *---------------------------------------------------------------------- */ | |
| 1676 | ||
| 1677 | void | |
| 1678 | Tcl_DStringFree(dsPtr) | |
| 1679 | Tcl_DString *dsPtr; /* Structure describing dynamic string. */ | |
| 1680 | { | |
| 1681 | if (dsPtr->string != dsPtr->staticSpace) { | |
| 1682 | ckfree(dsPtr->string); | |
| 1683 | } | |
| 1684 | dsPtr->string = dsPtr->staticSpace; | |
| 1685 | dsPtr->length = 0; | |
| 1686 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; | |
| 1687 | dsPtr->staticSpace[0] = '\0'; | |
| 1688 | } | |
| 1689 | ||
| 1690 | /* | |
| 1691 | *---------------------------------------------------------------------- | |
| 1692 | * | |
| 1693 | * Tcl_DStringResult -- | |
| 1694 | * | |
| 1695 | * This procedure moves the value of a dynamic string into an | |
| 1696 | * interpreter as its string result. Afterwards, the dynamic string | |
| 1697 | * is reset to an empty string. | |
| 1698 | * | |
| 1699 | * Results: | |
| 1700 | * None. | |
| 1701 | * | |
| 1702 | * Side effects: | |
| 1703 | * The string is "moved" to interp's result, and any existing | |
| 1704 | * string result for interp is freed. dsPtr is reinitialized to | |
| 1705 | * an empty string. | |
| 1706 | * | |
| 1707 | *---------------------------------------------------------------------- | |
| 1708 | */ | |
| 1709 | ||
| 1710 | void | |
| 1711 | Tcl_DStringResult(interp, dsPtr) | |
| 1712 | Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ | |
| 1713 | Tcl_DString *dsPtr; /* Dynamic string that is to become the | |
| 1714 | * result of interp. */ | |
| 1715 | { | |
| 1716 | Tcl_ResetResult(interp); | |
| 1717 | ||
| 1718 | if (dsPtr->string != dsPtr->staticSpace) { | |
| 1719 | interp->result = dsPtr->string; | |
| 1720 | interp->freeProc = TCL_DYNAMIC; | |
| 1721 | } else if (dsPtr->length < TCL_RESULT_SIZE) { | |
| 1722 | interp->result = ((Interp *) interp)->resultSpace; | |
| 1723 | strcpy(interp->result, dsPtr->string); | |
| 1724 | } else { | |
| 1725 | Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); | |
| 1726 | } | |
| 1727 | ||
| 1728 | dsPtr->string = dsPtr->staticSpace; | |
| 1729 | dsPtr->length = 0; | |
| 1730 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; | |
| 1731 | dsPtr->staticSpace[0] = '\0'; | |
| 1732 | } | |
| 1733 | ||
| 1734 | /* | |
| 1735 | *---------------------------------------------------------------------- | |
| 1736 | * | |
| 1737 | * Tcl_DStringGetResult -- | |
| 1738 | * | |
| 1739 | * This procedure moves an interpreter's result into a dynamic string. | |
| 1740 | * | |
| 1741 | * Results: | |
| 1742 | * None. | |
| 1743 | * | |
| 1744 | * Side effects: | |
| 1745 | * The interpreter's string result is cleared, and the previous | |
| 1746 | * contents of dsPtr are freed. | |
| 1747 | * | |
| 1748 | * If the string result is empty, the object result is moved to the | |
| 1749 | * string result, then the object result is reset. | |
| 1750 | * | |
| 1751 | *---------------------------------------------------------------------- | |
| 1752 | */ | |
| 1753 | ||
| 1754 | void | |
| 1755 | Tcl_DStringGetResult(interp, dsPtr) | |
| 1756 | Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ | |
| 1757 | Tcl_DString *dsPtr; /* Dynamic string that is to become the | |
| 1758 | * result of interp. */ | |
| 1759 | { | |
| 1760 | Interp *iPtr = (Interp *) interp; | |
| 1761 | ||
| 1762 | if (dsPtr->string != dsPtr->staticSpace) { | |
| 1763 | ckfree(dsPtr->string); | |
| 1764 | } | |
| 1765 | ||
| 1766 | /* | |
| 1767 | * If the string result is empty, move the object result to the | |
| 1768 | * string result, then reset the object result. | |
| 1769 | */ | |
| 1770 | ||
| 1771 | if (*(iPtr->result) == 0) { | |
| 1772 | Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), | |
| 1773 | TCL_VOLATILE); | |
| 1774 | } | |
| 1775 | ||
| 1776 | dsPtr->length = strlen(iPtr->result); | |
| 1777 | if (iPtr->freeProc != NULL) { | |
| 1778 | if ((iPtr->freeProc == TCL_DYNAMIC) | |
| 1779 | || (iPtr->freeProc == (Tcl_FreeProc *) free)) { | |
| 1780 | dsPtr->string = iPtr->result; | |
| 1781 | dsPtr->spaceAvl = dsPtr->length+1; | |
| 1782 | } else { | |
| 1783 | dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); | |
| 1784 | strcpy(dsPtr->string, iPtr->result); | |
| 1785 | (*iPtr->freeProc)(iPtr->result); | |
| 1786 | } | |
| 1787 | dsPtr->spaceAvl = dsPtr->length+1; | |
| 1788 | iPtr->freeProc = NULL; | |
| 1789 | } else { | |
| 1790 | if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { | |
| 1791 | dsPtr->string = dsPtr->staticSpace; | |
| 1792 | dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; | |
| 1793 | } else { | |
| 1794 | dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); | |
| 1795 | dsPtr->spaceAvl = dsPtr->length + 1; | |
| 1796 | } | |
| 1797 | strcpy(dsPtr->string, iPtr->result); | |
| 1798 | } | |
| 1799 | ||
| 1800 | iPtr->result = iPtr->resultSpace; | |
| 1801 | iPtr->resultSpace[0] = 0; | |
| 1802 | } | |
| 1803 | ||
| 1804 | /* | |
| 1805 | *---------------------------------------------------------------------- | |
| 1806 | * | |
| 1807 | * Tcl_DStringStartSublist -- | |
| 1808 | * | |
| 1809 | * This procedure adds the necessary information to a dynamic | |
| 1810 | * string (e.g. " {" to start a sublist. Future element | |
| 1811 | * appends will be in the sublist rather than the main list. | |
| 1812 | * | |
| 1813 | * Results: | |
| 1814 | * None. | |
| 1815 | * | |
| 1816 | * Side effects: | |
| 1817 | * Characters get added to the dynamic string. | |
| 1818 | * | |
| 1819 | *---------------------------------------------------------------------- | |
| 1820 | */ | |
| 1821 | ||
| 1822 | void | |
| 1823 | Tcl_DStringStartSublist(dsPtr) | |
| 1824 | Tcl_DString *dsPtr; /* Dynamic string. */ | |
| 1825 | { | |
| 1826 | if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { | |
| 1827 | Tcl_DStringAppend(dsPtr, " {", -1); | |
| 1828 | } else { | |
| 1829 | Tcl_DStringAppend(dsPtr, "{", -1); | |
| 1830 | } | |
| 1831 | } | |
| 1832 | ||
| 1833 | /* | |
| 1834 | *---------------------------------------------------------------------- | |
| 1835 | * | |
| 1836 | * Tcl_DStringEndSublist -- | |
| 1837 | * | |
| 1838 | * This procedure adds the necessary characters to a dynamic | |
| 1839 | * string to end a sublist (e.g. "}"). Future element appends | |
| 1840 | * will be in the enclosing (sub)list rather than the current | |
| 1841 | * sublist. | |
| 1842 | * | |
| 1843 | * Results: | |
| 1844 | * None. | |
| 1845 | * | |
| 1846 | * Side effects: | |
| 1847 | * None. | |
| 1848 | * | |
| 1849 | *---------------------------------------------------------------------- | |
| 1850 | */ | |
| 1851 | ||
| 1852 | void | |
| 1853 | Tcl_DStringEndSublist(dsPtr) | |
| 1854 | Tcl_DString *dsPtr; /* Dynamic string. */ | |
| 1855 | { | |
| 1856 | Tcl_DStringAppend(dsPtr, "}", -1); | |
| 1857 | } | |
| 1858 | ||
| 1859 | /* | |
| 1860 | *---------------------------------------------------------------------- | |
| 1861 | * | |
| 1862 | * Tcl_PrintDouble -- | |
| 1863 | * | |
| 1864 | * Given a floating-point value, this procedure converts it to | |
| 1865 | * an ASCII string using. | |
| 1866 | * | |
| 1867 | * Results: | |
| 1868 | * The ASCII equivalent of "value" is written at "dst". It is | |
| 1869 | * written using the current precision, and it is guaranteed to | |
| 1870 | * contain a decimal point or exponent, so that it looks like | |
| 1871 | * a floating-point value and not an integer. | |
| 1872 | * | |
| 1873 | * Side effects: | |
| 1874 | * None. | |
| 1875 | * | |
| 1876 | *---------------------------------------------------------------------- | |
| 1877 | */ | |
| 1878 | ||
| 1879 | void | |
| 1880 | Tcl_PrintDouble(interp, value, dst) | |
| 1881 | Tcl_Interp *interp; /* Interpreter whose tcl_precision | |
| 1882 | * variable used to be used to control | |
| 1883 | * printing. It's ignored now. */ | |
| 1884 | double value; /* Value to print as string. */ | |
| 1885 | char *dst; /* Where to store converted value; | |
| 1886 | * must have at least TCL_DOUBLE_SPACE | |
| 1887 | * characters. */ | |
| 1888 | { | |
| 1889 | char *p, c; | |
| 1890 | Tcl_UniChar ch; | |
| 1891 | ||
| 1892 | Tcl_MutexLock(&precisionMutex); | |
| 1893 | sprintf(dst, precisionFormat, value); | |
| 1894 | Tcl_MutexUnlock(&precisionMutex); | |
| 1895 | ||
| 1896 | /* | |
| 1897 | * If the ASCII result looks like an integer, add ".0" so that it | |
| 1898 | * doesn't look like an integer anymore. This prevents floating-point | |
| 1899 | * values from being converted to integers unintentionally. | |
| 1900 | */ | |
| 1901 | ||
| 1902 | for (p = dst; *p != 0; ) { | |
| 1903 | p += Tcl_UtfToUniChar(p, &ch); | |
| 1904 | c = UCHAR(ch); | |
| 1905 | if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ | |
| 1906 | return; | |
| 1907 | } | |
| 1908 | } | |
| 1909 | p[0] = '.'; | |
| 1910 | p[1] = '0'; | |
| 1911 | p[2] = 0; | |
| 1912 | } | |
| 1913 | ||
| 1914 | /* | |
| 1915 | *---------------------------------------------------------------------- | |
| 1916 | * | |
| 1917 | * TclPrecTraceProc -- | |
| 1918 | * | |
| 1919 | * This procedure is invoked whenever the variable "tcl_precision" | |
| 1920 | * is written. | |
| 1921 | * | |
| 1922 | * Results: | |
| 1923 | * Returns NULL if all went well, or an error message if the | |
| 1924 | * new value for the variable doesn't make sense. | |
| 1925 | * | |
| 1926 | * Side effects: | |
| 1927 | * If the new value doesn't make sense then this procedure | |
| 1928 | * undoes the effect of the variable modification. Otherwise | |
| 1929 | * it modifies the format string that's used by Tcl_PrintDouble. | |
| 1930 | * | |
| 1931 | *---------------------------------------------------------------------- | |
| 1932 | */ | |
| 1933 | ||
| 1934 | /* ARGSUSED */ | |
| 1935 | char * | |
| 1936 | TclPrecTraceProc(clientData, interp, name1, name2, flags) | |
| 1937 | ClientData clientData; /* Not used. */ | |
| 1938 | Tcl_Interp *interp; /* Interpreter containing variable. */ | |
| 1939 | char *name1; /* Name of variable. */ | |
| 1940 | char *name2; /* Second part of variable name. */ | |
| 1941 | int flags; /* Information about what happened. */ | |
| 1942 | { | |
| 1943 | char *value, *end; | |
| 1944 | int prec; | |
| 1945 | ||
| 1946 | /* | |
| 1947 | * If the variable is unset, then recreate the trace. | |
| 1948 | */ | |
| 1949 | ||
| 1950 | if (flags & TCL_TRACE_UNSETS) { | |
| 1951 | if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { | |
| 1952 | Tcl_TraceVar2(interp, name1, name2, | |
| 1953 | TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES | |
| 1954 | |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); | |
| 1955 | } | |
| 1956 | return (char *) NULL; | |
| 1957 | } | |
| 1958 | ||
| 1959 | /* | |
| 1960 | * When the variable is read, reset its value from our shared | |
| 1961 | * value. This is needed in case the variable was modified in | |
| 1962 | * some other interpreter so that this interpreter's value is | |
| 1963 | * out of date. | |
| 1964 | */ | |
| 1965 | ||
| 1966 | Tcl_MutexLock(&precisionMutex); | |
| 1967 |