/* * tclUtil.c -- * * This file contains utility functions 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. * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include /* * The absolute pathname of the executable in which this Tcl library is * running. */ static ProcessGlobalValue executableName = { 0, 0, NULL, NULL, NULL, NULL, NULL }; /* * The following values are used in the flags returned by Tcl_ScanElement and * used by Tcl_ConvertElement. The values TCL_DONT_USE_BRACES and * TCL_DONT_QUOTE_HASH are defined in tcl.h; make sure neither value overlaps * 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. * TCL_DONT_QUOTE_HASH - 1 means the caller insists that a leading hash * character ('#') should *not* be quoted. This * is appropriate when the caller can guarantee * the element is not the first element of a * list, so [eval] cannot mis-parse the element * as a comment. */ #define USE_BRACES 2 #define BRACES_UNMATCHED 4 /* * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to * access the precision to be used for double formatting. */ static Tcl_ThreadDataKey precisionKey; /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a * performance optimization in TclGetIntForIndex. The internal rep is an * integer, so no memory management is required for it. */ const Tcl_ObjType tclEndOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfEndOffset, /* updateStringProc */ SetEndOffsetFromAny }; /* *---------------------------------------------------------------------- * * TclCountSpaceRuns -- * * Given 'bytes' pointing to 'numBytes' bytes, scan through them and * count the number of whitespace runs that could be list element * separators. If 'numBytes' is -1, scan to the terminating '\0'. * * Results: * Returns the count. If 'endPtr' is not NULL, writes a pointer to * the end of the string scanned there. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclCountSpaceRuns( CONST char *bytes, int numBytes, CONST char **endPtr) { int count = 0; while (numBytes) { if ((numBytes == -1) && (*bytes == '\0')) { break; } if (TclIsSpaceProc(*bytes)) { /* Space run started; bump count */ count++; do { bytes++; numBytes -= (numBytes != -1); } while (numBytes && TclIsSpaceProc(*bytes)); if (numBytes == 0) { break; } /* (*bytes) is non-space; return to counting state */ } bytes++; numBytes -= (numBytes != -1); } if (endPtr) { *endPtr = bytes; } return count; } /* *---------------------------------------------------------------------- * * 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 function does NOT collapse backslash * sequences. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclFindElement( 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) && (TclIsSpaceProc(*p))) { 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) || TclIsSpaceProc(*p)) { goto done; } /* * Garbage after the closing brace; return an error. */ if (interp != NULL) { p2 = p; while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in braces followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", NULL); } return TCL_ERROR; } break; /* * Backslash: skip over everything up to the end of the backslash * sequence. */ case '\\': TclParseBackslash(p, limit - 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) || TclIsSpaceProc(*p)) { goto done; } /* * Garbage after the closing quote; return an error. */ if (interp != NULL) { p2 = p; while ((p2 < limit) && (!TclIsSpaceProc(*p2)) && (p2 < p+20)) { p2++; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list element in quotes followed by \"%.*s\" " "instead of space", (int) (p2-p), p)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK", NULL); } 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); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE", NULL); } return TCL_ERROR; } else if (inQuotes) { if (interp != NULL) { Tcl_SetResult(interp, "unmatched open quote in list", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE", NULL); } return TCL_ERROR; } size = (p - elemStart); } done: while ((p < limit) && (TclIsSpaceProc(*p))) { p++; } *elementPtr = elemStart; *nextPtr = p; if (sizePtr != 0) { *sizePtr = size; } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCopyAndCollapse -- * * Copy a string and substitute all backslash escape sequences * * Results: * Count bytes get copied from src to dst. Along the way, backslash * sequences are substituted in the copy. After scanning count bytes * from src, a null character is placed at the end of dst. Returns * the number of bytes that got written to dst. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclCopyAndCollapse( int count, /* Number of byte to copy from src. */ const char *src, /* Copy from here... */ char *dst) /* ... to here. */ { int newCount = 0; while (count > 0) { char c = *src; if (c == '\\') { int numRead; int backslashCount = TclParseBackslash(src, count, &numRead, dst); dst += backslashCount; newCount += backslashCount; src += numRead; count -= numRead; } else { *dst = c; dst++; newCount++; src++; count--; } } *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 * function returns normally. * * Side effects: * Memory is allocated. * *---------------------------------------------------------------------- */ int Tcl_SplitList( 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. */ const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to list elements. */ { const char **argv, *end, *element; char *p; int length, size, i, result, elSize, brace; /* * 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. */ size = TclCountSpaceRuns(list, -1, &end) + 2; length = end - list; argv = ckalloc((size * sizeof(char *)) + length + 1); 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(argv); return result; } if (*element == 0) { break; } if (i >= size) { ckfree(argv); if (interp != NULL) { Tcl_SetResult(interp, "internal error in Tcl_SplitList", TCL_STATIC); Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList", NULL); } return TCL_ERROR; } argv[i] = p; if (brace) { memcpy(p, element, (size_t) elSize); p += elSize; *p = 0; p++; } else { TclCopyAndCollapse(elSize, element, p); p += elSize+1; } } argv[i] = NULL; *argvPtr = argv; *argcPtr = i; return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_ScanElement -- * * This function is a companion function 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( 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 function is a companion function 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( 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 function 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 function 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 function 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 functions 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; TclParseBackslash(p, lastChar - 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 function to Tcl_ScanElement. Given the information * produced by Tcl_ScanElement, this function 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( 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 function to Tcl_ScanCountedElement. Given the * information produced by Tcl_ScanCountedElement, this function 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( 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 ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { flags |= USE_BRACES; } 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; } else if ((*src == '#') && !(flags & TCL_DONT_QUOTE_HASH)) { /* * Leading '#' could be seen by [eval] as the start of a comment, * if on the first element of a list, so quote it. */ p[0] = '\\'; p[1] = '#'; p += 2; src++; } 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( int argc, /* How many strings to merge. */ const char *const *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 = ckalloc(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 = ckalloc(numChars); dst = result; for (i = 0; i < argc; i++) { numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i] | (i==0 ? 0 : TCL_DONT_QUOTE_HASH)); dst += numChars; *dst = ' '; dst++; } if (dst == result) { *dst = 0; } else { dst[-1] = 0; } if (flagPtr != localFlags) { ckfree(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( 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); TclUtfToUniChar(buf, &ch); return (char) ch; } /* *---------------------------------------------------------------------- * * TclTrimRight -- * Takes two counted strings in the Tcl encoding which must both be * null terminated. Conceptually trims from the right side of the * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclTrimRight( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes + numBytes; int pInc; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimRight works only on null-terminated strings"); } /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* Outer loop: iterate over string to be trimmed */ do { Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); /* Inner loop: scan trim string for match to current character */ do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } q += qInc; bytesLeft -= qInc; } while (bytesLeft); if (bytesLeft == 0) { /* No match; trim task done; *p is last non-trimmed char */ p += pInc; break; } } while (p > bytes); return numBytes - (p - bytes); } /* *---------------------------------------------------------------------- * * TclTrimLeft -- * Takes two counted strings in the Tcl encoding which must both be * null terminated. Conceptually trims from the left side of the * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclTrimLeft( const char *bytes, /* String to be trimmed... */ int numBytes, /* ...and its length in bytes */ const char *trim, /* String of trim characters... */ int numTrim) /* ...and its length in bytes */ { const char *p = bytes; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* Outer loop: iterate over string to be trimmed */ do { Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; /* Inner loop: scan trim string for match to current character */ do { Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } q += qInc; bytesLeft -= qInc; } while (bytesLeft); if (bytesLeft == 0) { /* No match; trim task done; *p is first non-trimmed char */ break; } p += pInc; numBytes -= pInc; } while (numBytes); return p - bytes; } /* *---------------------------------------------------------------------- * * 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. * *---------------------------------------------------------------------- */ /* The whitespace characters trimmed during [concat] operations */ #define CONCAT_WS " \f\v\r\t\n" #define CONCAT_WS_SIZE (int) (sizeof(CONCAT_WS "") - 1) char * Tcl_Concat( int argc, /* Number of strings to concatenate. */ const char *const *argv) /* Array of strings to concatenate. */ { int i, needSpace = 0, bytesNeeded = 0; char *result, *p; /* Dispose of the empty result corner case first to simplify later code */ if (argc == 0) { result = (char *) ckalloc(1); result[0] = '\0'; return result; } /* First allocate the result buffer at the size required */ for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); if (bytesNeeded < 0) { Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } } if (bytesNeeded + argc - 1 < 0) { /* * Panic test could be tighter, but not going to bother for * this legacy routine. */ Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } /* All element bytes + (argc - 1) spaces + 1 terminating NULL */ result = (char *) ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { int trim, elemLength; const char *element; element = argv[i]; elemLength = strlen(argv[i]); /* Trim away the leading whitespace */ trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* * Trim away the trailing whitespace. Do not permit trimming * to expose a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; /* If we're left with empty element after trimming, do nothing */ if (elemLength == 0) { continue; } /* Append to the result with space if needed */ if (needSpace) { *p++ = ' '; } memcpy(p, element, (size_t) elemLength); p += elemLength; needSpace = 1; } *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( int objc, /* Number of objects to concatenate. */ Tcl_Obj *const objv[]) /* Array of objects to concatenate. */ { int i, elemLength, needSpace = 0, bytesNeeded = 0; const char *element; Tcl_Obj *objPtr, *resPtr; /* * Check first to see if all the items are of list type or empty. If so, * we will concat them together as lists, and return a list object. This * is only valid when the lists are in canonical form. */ for (i = 0; i < objc; i++) { int length; objPtr = objv[i]; if (TclListObjIsCanonical(objPtr)) { continue; } Tcl_GetStringFromObj(objPtr, &length); if (length > 0) { break; } } if (i == objc) { Tcl_Obj **listv; int listc; resPtr = 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. * Note that all objs at this point are either lists or have an * empty string rep. */ objPtr = objv[i]; if (objPtr->bytes && objPtr->length == 0) { continue; } TclListObjGetElements(NULL, objPtr, &listc, &listv); if (listc) { if (resPtr) { Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv); } else { resPtr = TclListObjCopy(NULL, objPtr); } } } if (!resPtr) { resPtr = Tcl_NewObj(); } return resPtr; } /* * Something cannot be determined to be safe, so build the concatenation * the slow way, using the string representations. */ /* First try to pre-allocate the size required */ for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); bytesNeeded += elemLength; if (bytesNeeded < 0) { break; } } /* * Does not matter if this fails, will simply try later to build up * the string with each Append reallocating as needed with the usual * string append algorithm. When that fails it will report the error. */ TclNewObj(resPtr); Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { int trim; element = TclGetStringFromObj(objv[i], &elemLength); /* Trim away the leading whitespace */ trim = TclTrimLeft(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); element += trim; elemLength -= trim; /* * Trim away the trailing whitespace. Do not permit trimming * to expose a final backslash character. */ trim = TclTrimRight(element, elemLength, CONCAT_WS, CONCAT_WS_SIZE); trim -= trim && (element[elemLength - trim - 1] == '\\'); elemLength -= trim; /* If we're left with empty element after trimming, do nothing */ if (elemLength == 0) { continue; } /* Append to the result with space if needed */ if (needSpace) { Tcl_AppendToObj(resPtr, " ", 1); } Tcl_AppendToObj(resPtr, element, elemLength); needSpace = 1; } return resPtr; } /* *---------------------------------------------------------------------- * * 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( const char *str, /* String. */ const char *pattern) /* Pattern, which may contain special * characters. */ { return Tcl_StringCaseMatch(str, pattern, 0); } /* *---------------------------------------------------------------------- * * 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( const char *str, /* String. */ const char *pattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; const char *pstart = pattern; Tcl_UniChar ch1, ch2; while (1) { p = *pattern; /* * 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 (*str == '\0'); } if ((*str == '\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 == '*') { /* * Skip all successive *'s in the pattern */ while (*(++pattern) == '*') {} p = *pattern; if (p == '\0') { return 1; } /* * This is a special case optimization for single-byte utf. */ if (UCHAR(*pattern) < 0x80) { ch2 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); } else { Tcl_UtfToUniChar(pattern, &ch2); if (nocase) { ch2 = Tcl_UniCharToLower(ch2); } } while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character */ if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { break; } str += charLen; } } else { /* * There's no point in trying to make this code * shorter, as the number of bytes you want to compare * each time is non-constant. */ while (*str) { charLen = TclUtfToUniChar(str, &ch1); if (ch2 == ch1) { break; } str += charLen; } } } if (Tcl_StringCaseMatch(str, pattern, nocase)) { return 1; } if (*str == '\0') { return 0; } str += TclUtfToUniChar(str, &ch1); } } /* * Check for a "?" as the next pattern character. It matches any * single character. */ if (p == '?') { pattern++; str += TclUtfToUniChar(str, &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++; if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); str++; } else { str += Tcl_UtfToUniChar(str, &ch1); if (nocase) { ch1 = Tcl_UniCharToLower(ch1); } } while (1) { if ((*pattern == ']') || (*pattern == '\0')) { return 0; } if (UCHAR(*pattern) < 0x80) { startChar = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { pattern += Tcl_UtfToUniChar(pattern, &startChar); if (nocase) { startChar = Tcl_UniCharToLower(startChar); } } if (*pattern == '-') { pattern++; if (*pattern == '\0') { return 0; } if (UCHAR(*pattern) < 0x80) { endChar = (Tcl_UniChar) (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); pattern++; } else { 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++; if (*pattern == '\0') { return 0; } } /* * There's no special character. Just make sure that the next bytes of * each string match. */ str += TclUtfToUniChar(str, &ch1); pattern += TclUtfToUniChar(pattern, &ch2); if (nocase) { if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { return 0; } } else if (ch1 != ch2) { return 0; } } } /* *---------------------------------------------------------------------- * * TclByteArrayMatch -- * * See if a particular string matches a particular pattern. Does not * allow for case insensitivity. * Parallels tclUtf.c:TclUniCharMatch, adjusted for char* and sans nocase. * * 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 TclByteArrayMatch( const unsigned char *string,/* String. */ int strLen, /* Length of String */ const unsigned char *pattern, /* Pattern, which may contain special * characters. */ int ptnLen, /* Length of Pattern */ int flags) { const unsigned char *stringEnd, *patternEnd; unsigned char p; stringEnd = string + strLen; patternEnd = pattern + ptnLen; while (1) { /* * See if we're at the end of both the pattern and the string. If so, * we succeeded. If we're at the end of the pattern but not at the end * of the string, we failed. */ if (pattern == patternEnd) { return (string == stringEnd); } p = *pattern; if ((string == stringEnd) && (p != '*')) { return 0; } /* * Check for a "*" as the next pattern character. It matches any * substring. We handle this by skipping all the characters up to the * next matching one in the pattern, and then calling ourselves * recursively for each postfix of string, until either we match or we * reach the end of the string. */ if (p == '*') { /* * Skip all successive *'s in the pattern. */ while ((++pattern < patternEnd) && (*pattern == '*')) { /* empty body */ } if (pattern == patternEnd) { return 1; } p = *pattern; while (1) { /* * Optimization for matching - cruise through the string * quickly if the next char in the pattern isn't a special * character. */ if ((p != '[') && (p != '?') && (p != '\\')) { while ((string < stringEnd) && (p != *string)) { string++; } } if (TclByteArrayMatch(string, stringEnd - string, pattern, patternEnd - pattern, 0)) { return 1; } if (string == stringEnd) { return 0; } string++; } } /* * Check for a "?" as the next pattern character. It matches any * single character. */ if (p == '?') { pattern++; string++; 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 == '[') { unsigned char ch1, startChar, endChar; pattern++; ch1 = *string; string++; while (1) { if ((*pattern == ']') || (pattern == patternEnd)) { return 0; } startChar = *pattern; pattern++; if (*pattern == '-') { pattern++; if (pattern == patternEnd) { return 0; } endChar = *pattern; pattern++; 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 == patternEnd) { pattern--; 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 == '\\') { if (++pattern == patternEnd) { return 0; } } /* * There's no special character. Just make sure that the next bytes of * each string match. */ if (*string != *pattern) { return 0; } string++; pattern++; } } /* *---------------------------------------------------------------------- * * TclStringMatchObj -- * * See if a particular string matches a particular pattern. * Allows case insensitivity. This is the generic multi-type handler * for the various matching algorithms. * * 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 TclStringMatchObj( Tcl_Obj *strObj, /* string object. */ Tcl_Obj *ptnObj, /* pattern object. */ int flags) /* Only TCL_MATCH_NOCASE should be passed, or * 0. */ { int match, length, plen; /* * Promote based on the type of incoming object. * XXX: Currently doesn't take advantage of exact-ness that * XXX: TclReToGlob tells us about trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); match = TclByteArrayMatch(data, length, ptn, plen, 0); } else { match = Tcl_StringCaseMatch(TclGetString(strObj), TclGetString(ptnObj), flags); } return match; } /* *---------------------------------------------------------------------- * * 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( 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 bytes 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 "bytes" (or all of "bytes" 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( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *bytes, /* String to append. If length is -1 then this * must be null-terminated. */ int length) /* Number of bytes from "bytes" to append. If * < 0, then append all of bytes, up to null * at end. */ { int newSize; if (length < 0) { length = strlen(bytes); } 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 = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } /* * Copy the new string into the buffer at the end of the old one. */ memcpy(dsPtr->string + dsPtr->length, bytes, length); dsPtr->length += length; dsPtr->string[dsPtr->length] = '\0'; 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( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *element) /* String to append. Must be * null-terminated. */ { int newSize, flags, strSize; char *dst; strSize = ((element== NULL) ? 0 : strlen(element)); newSize = Tcl_ScanCountedElement(element, strSize, &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 = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = ckrealloc(dsPtr->string, 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++; /* * If we need a space to separate this element from preceding stuff, * then this element will not lead a list, and need not have it's * leading '#' quoted. */ flags |= TCL_DONT_QUOTE_HASH; } dsPtr->length += Tcl_ConvertCountedElement(element, strSize, 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( 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 = ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, (size_t) dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = ckrealloc(dsPtr->string, 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( 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 function 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( 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; Tcl_ResetResult(interp); if (dsPtr->string != dsPtr->staticSpace) { iPtr->result = dsPtr->string; iPtr->freeProc = TCL_DYNAMIC; } else if (dsPtr->length < TCL_RESULT_SIZE) { iPtr->result = iPtr->resultSpace; memcpy(iPtr->result, dsPtr->string, dsPtr->length + 1); } 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 function 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( 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. */ (void) Tcl_GetStringResult(interp); dsPtr->length = strlen(iPtr->result); if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { dsPtr->string = iPtr->result; dsPtr->spaceAvl = dsPtr->length+1; } else { dsPtr->string = ckalloc(dsPtr->length+1); memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); 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 = ckalloc(dsPtr->length+1); dsPtr->spaceAvl = dsPtr->length + 1; } memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; } /* *---------------------------------------------------------------------- * * Tcl_DStringStartSublist -- * * This function 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( 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 function 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( Tcl_DString *dsPtr) /* Dynamic string. */ { Tcl_DStringAppend(dsPtr, "}", -1); } /* *---------------------------------------------------------------------- * * Tcl_PrintDouble -- * * Given a floating-point value, this function 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( 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; int exponent; int signum; char *digits; char *end; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * Handle NaN. */ if (TclIsNaN(value)) { TclFormatNaN(value, dst); return; } /* * Handle infinities. */ if (TclIsInfinite(value)) { /* * Remember to copy the terminating NUL too. */ if (value < 0) { memcpy(dst, "-Inf", 5); } else { memcpy(dst, "Inf", 4); } return; } /* * Ordinary (normal and denormal) values. */ if (*precisionPtr == 0) { digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); } else { /* * There are at least two possible interpretations for tcl_precision. * * The first is, "choose the decimal representation having * $tcl_precision digits of significance that is nearest to the given * number, breaking ties by rounding to even, and then trimming * trailing zeros." This gives the greatest possible precision in the * decimal string, but offers the anomaly that [expr 0.1] will be * "0.10000000000000001". * * The second is "choose the decimal representation having at most * $tcl_precision digits of significance that is nearest to the given * number. If no such representation converts exactly to the given * number, choose the one that is closest, breaking ties by rounding * to even. If more than one such representation converts exactly to * the given number, choose the shortest, breaking ties in favour of * the nearest, breaking remaining ties in favour of the one ending in * an even digit." * * Tcl 8.4 implements the first of these, which gives rise to * anomalies in formatting: * * % expr 0.1 * 0.10000000000000001 * % expr 0.01 * 0.01 * % expr 1e-7 * 9.9999999999999995e-08 * * For human readability, it appears better to choose the second rule, * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer * the first (the recommended zero value for tcl_precision avoids the * problem entirely). * * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method * that allows floating point values to be shortened if it can be done * without loss of precision. */ digits = TclDoubleDigits(value, *precisionPtr, TCL_DD_E_FORMAT /* | TCL_DD_SHORTEN_FLAG */, &exponent, &signum, &end); } if (signum) { *dst++ = '-'; } p = digits; if (exponent < -4 || exponent > 16) { /* * E format for numbers < 1e-3 or >= 1e17. */ *dst++ = *p++; c = *p; if (c != '\0') { *dst++ = '.'; while (c != '\0') { *dst++ = c; c = *++p; } } /* * Tcl 8.4 appears to format with at least a two-digit exponent; * preserve that behaviour when tcl_precision != 0 */ if (*precisionPtr == 0) { sprintf(dst, "e%+d", exponent); } else { sprintf(dst, "e%+03d", exponent); } } else { /* * F format for others. */ if (exponent < 0) { *dst++ = '0'; } c = *p; while (exponent-- >= 0) { if (c != '\0') { *dst++ = c; c = *++p; } else { *dst++ = '0'; } } *dst++ = '.'; if (c == '\0') { *dst++ = '0'; } else { while (++exponent < -1) { *dst++ = '0'; } while (c != '\0') { *dst++ = c; c = *++p; } } *dst++ = '\0'; } ckfree(digits); } /* *---------------------------------------------------------------------- * * TclPrecTraceProc -- * * This function 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 function undoes the * effect of the variable modification. Otherwise it modifies the format * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ /* ARGSUSED */ char * TclPrecTraceProc( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable. */ const char *name2, /* Second part of variable name. */ int flags) /* Information about what happened. */ { Tcl_Obj *value; int prec; int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); /* * If the variable is unset, then recreate the trace. */ if (flags & TCL_TRACE_UNSETS) { if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { Tcl_TraceVar2(interp, name1, name2, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); } return 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. */ if (flags & TCL_TRACE_READS) { Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); return 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)) { return (char *) "can't modify precision from a safe interpreter"; } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return (char *) "improper value for precision"; } *precisionPtr = prec; return NULL; } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This function 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( const char *start, /* First character in string. */ const 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 */ if (end == start) { return 0; } /* * (b) we're at the start of a nested list-element, quoted with an open * curly brace; we can be nested arbitrarily deep, so long as the * first curly brace starts an element, so backtrack over open curly * braces that are trailing characters of the string; and */ end = Tcl_UtfPrev(end, start); while (*end == '{') { if (end == start) { return 0; } end = Tcl_UtfPrev(end, start); } /* * (c) the trailing character of the string is already a list-element * separator (according to TclFindElement); that is, one of these * characters: * \u0009 \t TAB * \u000A \n NEWLINE * \u000B \v VERTICAL TAB * \u000C \f FORM FEED * \u000D \r CARRIAGE RETURN * \u0020 SPACE * with the condition that the penultimate character is not a * backslash. */ if (*end > 0x20) { /* * Performance tweak. All ASCII spaces are <= 0x20. So get a quick * answer for most characters before comparing against all spaces in * the switch below. * * NOTE: Remove this if other Unicode spaces ever get accepted as * list-element separators. */ return 1; } switch (*end) { case ' ': case '\t': case '\n': case '\r': case '\v': case '\f': if ((end == start) || (end[-1] != '\\')) { 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, "%ld", n) but is faster as proven in * benchmarks. This is key to UpdateStringOfInt, which is a common path * for a lot of code (e.g. int-indexed arrays). * * 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; const 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) { return sprintf(buffer, "%ld", n); } /* * 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; } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * * This function returns an integer corresponding to the list index held * in a Tcl object. The Tcl object's value is expected to be in the * format integer([+-]integer)? or the format 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 one of the * expected formats, 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, * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int TclGetIntForIndex( 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. */ { int length; char *opPtr; const char *bytes; if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; } if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* * If the object is already an offset from the end of the list, or can * be converted to one, use it. */ *indexPtr = endValue + objPtr->internalRep.longValue; return TCL_OK; } bytes = TclGetStringFromObj(objPtr, &length); /* * Leading whitespace is acceptable in an index. */ while (length && TclIsSpaceProc(*bytes)) { bytes++; length--; } if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { int code, first, second; char savedOp = *opPtr; if ((savedOp != '+') && (savedOp != '-')) { goto parseError; } if (TclIsSpaceProc(opPtr[1])) { goto parseError; } *opPtr = '\0'; code = Tcl_GetInt(interp, bytes, &first); *opPtr = savedOp; if (code == TCL_ERROR) { goto parseError; } if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { goto parseError; } if (savedOp == '+') { *indexPtr = first + second; } else { *indexPtr = first - second; } return TCL_OK; } /* * Report a parse error. */ parseError: if (interp != NULL) { /* * The result might not be empty; this resets it which should be both * a cheap operation, and of little problem because this is an * error-generation path anyway. */ bytes = Tcl_GetString(objPtr); Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be integer?[+-]integer? or end?[+-]integer?", NULL); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } TclCheckBadOctal(interp, bytes); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * UpdateStringOfEndOffset -- * * Update the string rep of a Tcl object holding an "end-offset" * expression. * * Results: * None. * * Side effects: * Stores a valid string in the object's string rep. * * This function does NOT free any earlier string rep. If it is called on an * object that already has a valid string rep, it will leak memory. * *---------------------------------------------------------------------- */ static void UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; register int len; memcpy(buffer, "end", sizeof("end") + 1); len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); } objPtr->bytes = ckalloc((unsigned) len+1); memcpy(objPtr->bytes, buffer, (unsigned) len+1); objPtr->length = len; } /* *---------------------------------------------------------------------- * * SetEndOffsetFromAny -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. * * Side effects: * If interp is not NULL, stores an error message in the interpreter * result. * *---------------------------------------------------------------------- */ static int SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { int offset; /* Offset in the "end-offset" expression */ register const char *bytes; /* String rep of the object */ int length; /* Length of the object's string rep */ /* * If it's already the right type, we're fine. */ if (objPtr->typePtr == &tclEndOffsetType) { return TCL_OK; } /* * Check for a string rep of the right form. */ bytes = TclGetStringFromObj(objPtr, &length); if ((*bytes != 'e') || (strncmp(bytes, "end", (size_t)((length > 3) ? 3 : length)) != 0)) { if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } /* * Convert the string rep. */ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything * after "end-" to Tcl_GetInt, then reverse for offset. */ if (TclIsSpaceProc(bytes[4])) { goto badIndexFormat; } if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { return TCL_ERROR; } if (bytes[3] == '-') { offset = -offset; } } else { /* * Conversion failed. Report the error. */ badIndexFormat: if (interp != NULL) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, "bad index \"", bytes, "\": must be end?[+-]integer?", NULL); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); objPtr->internalRep.longValue = offset; objPtr->typePtr = &tclEndOffsetType; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCheckBadOctal -- * * This function 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( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after * errors. */ const char *value) /* String to check. */ { register const char *p = value; /* * A frequent mistake is invalid octal values due to an unwanted leading * zero. Try to generate a meaningful error message. */ while (TclIsSpaceProc(*p)) { p++; } if (*p == '+' || *p == '-') { p++; } if (*p == '0') { if ((p[1] == 'o') || p[1] == 'O') { p += 2; } while (isdigit(UCHAR(*p))) { /* INTL: digit. */ p++; } while (TclIsSpaceProc(*p)) { p++; } if (*p == '\0') { /* * Reached end of string. */ if (interp != NULL) { /* * Don't reset the result here because we want this result to * be added to an existing error message as extra info. */ Tcl_AppendResult(interp, " (looks like invalid octal number)", NULL); } return 1; } } return 0; } /* *---------------------------------------------------------------------- * * ClearHash -- * * Remove all the entries in the hash table *tablePtr. * *---------------------------------------------------------------------- */ static void ClearHash( Tcl_HashTable *tablePtr) { Tcl_HashSearch search; Tcl_HashEntry *hPtr; for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr); Tcl_DecrRefCount(objPtr); Tcl_DeleteHashEntry(hPtr); } } /* *---------------------------------------------------------------------- * * GetThreadHash -- * * Get a thread-specific (Tcl_HashTable *) associated with a thread data * key. * * Results: * The Tcl_HashTable * corresponding to *keyPtr. * * Side effects: * The first call on a keyPtr in each thread creates a new Tcl_HashTable, * and registers a thread exit handler to dispose of it. * *---------------------------------------------------------------------- */ static Tcl_HashTable * GetThreadHash( Tcl_ThreadDataKey *keyPtr) { Tcl_HashTable **tablePtrPtr = Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { *tablePtrPtr = ckalloc(sizeof(Tcl_HashTable)); Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } return *tablePtrPtr; } /* *---------------------------------------------------------------------- * * FreeThreadHash -- * * Thread exit handler used by GetThreadHash to dispose of a thread hash * table. * * Side effects: * Frees a Tcl_HashTable. * *---------------------------------------------------------------------- */ static void FreeThreadHash( ClientData clientData) { Tcl_HashTable *tablePtr = clientData; ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); ckfree(tablePtr); } /* *---------------------------------------------------------------------- * * FreeProcessGlobalValue -- * * Exit handler used by Tcl(Set|Get)ProcessGlobalValue to cleanup a * ProcessGlobalValue at exit. * *---------------------------------------------------------------------- */ static void FreeProcessGlobalValue( ClientData clientData) { ProcessGlobalValue *pgvPtr = clientData; pgvPtr->epoch++; pgvPtr->numBytes = 0; ckfree(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = NULL; } Tcl_MutexFinalize(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * * TclSetProcessGlobalValue -- * * Utility routine to set a global value shared by all threads in the * process while keeping a thread-local copy as well. * *---------------------------------------------------------------------- */ void TclSetProcessGlobalValue( ProcessGlobalValue *pgvPtr, Tcl_Obj *newValue, Tcl_Encoding encoding) { const char *bytes; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int dummy; Tcl_MutexLock(&pgvPtr->mutex); /* * Fill the global string value. */ pgvPtr->epoch++; if (NULL != pgvPtr->value) { ckfree(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr); } bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } pgvPtr->encoding = encoding; /* * Fill the local thread copy directly with the Tcl_Obj value to avoid * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * * TclGetProcessGlobalValue -- * * Retrieve a global value shared among all threads of the process, * preferring a thread-local copy as long as it remains valid. * * Results: * Returns a (Tcl_Obj *) that holds a copy of the global value. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetProcessGlobalValue( ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* * The system encoding has changed since the master string value * was saved. Convert the master value to be based on the new * system encoding. */ Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); pgvPtr->epoch++; epoch = pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); ckfree(pgvPtr->value); pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), (size_t) Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; Tcl_MutexUnlock(&pgvPtr->mutex); } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. * * First, clear the cacheMap, as anything in it must refer to some * expired epoch. */ ClearHash(cacheMap); /* * If no thread has set the shared value, call the initializer. */ Tcl_MutexLock(&pgvPtr->mutex); if ((NULL == pgvPtr->value) && (pgvPtr->proc)) { pgvPtr->epoch++; pgvPtr->proc(&pgvPtr->value,&pgvPtr->numBytes,&pgvPtr->encoding); if (pgvPtr->value == NULL) { Tcl_Panic("PGV Initializer did not initialize"); } Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); } return Tcl_GetHashValue(hPtr); } /* *---------------------------------------------------------------------- * * TclSetObjNameOfExecutable -- * * This function stores the absolute pathname of the executable file * (normally as computed by TclpFindExecutable). * * Results: * None. * * Side effects: * Stores the executable name. * *---------------------------------------------------------------------- */ void TclSetObjNameOfExecutable( Tcl_Obj *name, Tcl_Encoding encoding) { TclSetProcessGlobalValue(&executableName, name, encoding); } /* *---------------------------------------------------------------------- * * TclGetObjNameOfExecutable -- * * This function retrieves the absolute pathname of the application in * which the Tcl library is running, usually as previously stored by * TclpFindExecutable(). This function call is the C API equivalent to * the "info nameofexecutable" command. * * Results: * A pointer to an "fsPath" Tcl_Obj, or to an empty Tcl_Obj if the * pathname of the application is unknown. * * Side effects: * None. * *---------------------------------------------------------------------- */ Tcl_Obj * TclGetObjNameOfExecutable(void) { return TclGetProcessGlobalValue(&executableName); } /* *---------------------------------------------------------------------- * * Tcl_GetNameOfExecutable -- * * This function retrieves the absolute pathname of the application in * which the Tcl library is running, and returns it in string form. * * The returned string belongs to Tcl and should be copied if the caller * plans to keep it, to guard against it becoming invalid. * * Results: * A pointer to the internal string or NULL if the internal full path * name has not been computed or unknown. * * Side effects: * None. * *---------------------------------------------------------------------- */ const char * Tcl_GetNameOfExecutable(void) { int numBytes; const char *bytes = Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); if (numBytes == 0) { return NULL; } return bytes; } /* *---------------------------------------------------------------------- * * TclpGetTime -- * * Deprecated synonym for Tcl_GetTime. This function is provided for the * benefit of extensions written before Tcl_GetTime was exported from the * library. * * Results: * None. * * Side effects: * Stores current time in the buffer designated by "timePtr" * *---------------------------------------------------------------------- */ void TclpGetTime( Tcl_Time *timePtr) { Tcl_GetTime(timePtr); } /* *---------------------------------------------------------------------- * * TclGetPlatform -- * * This is a kludge that allows the test library to get access the * internal tclPlatform variable. * * Results: * Returns a pointer to the tclPlatform variable. * * Side effects: * None. * *---------------------------------------------------------------------- */ TclPlatformType * TclGetPlatform(void) { return &tclPlatform; } /* *---------------------------------------------------------------------- * * TclReToGlob -- * * Attempt to convert a regular expression to an equivalent glob pattern. * * Results: * Returns TCL_OK on success, TCL_ERROR on failure. If interp is not * NULL, an error message is placed in the result. On success, the * DString will contain an exact equivalent glob pattern. The caller is * responsible for calling Tcl_DStringFree on success. If exactPtr is not * NULL, it will be 1 if an exact match qualifies. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclReToGlob( Tcl_Interp *interp, const char *reStr, int reStrLen, Tcl_DString *dsPtr, int *exactPtr) { int anchorLeft, anchorRight, lastIsStar, numStars; char *dsStr, *dsStrStart; const char *msg, *p, *strEnd, *code; strEnd = reStr + reStrLen; Tcl_DStringInit(dsPtr); /* * "***=xxx" == "*xxx*", watch for glob-sensitive chars. */ if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) { /* * At most, the glob pattern has length 2*reStrLen + 2 to backslash * escape every character and have * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); *dsStr++ = '*'; for (p = reStr + 4; p < strEnd; p++) { switch (*p) { case '\\': case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ *dsStr++ = '\\'; /* fall through */ default: *dsStr++ = *p; break; } } *dsStr++ = '*'; Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart); if (exactPtr) { *exactPtr = 0; } return TCL_OK; } /* * At most, the glob pattern has length reStrLen + 2 to account for * possible * at each end. */ Tcl_DStringSetLength(dsPtr, reStrLen + 2); dsStr = dsStrStart = Tcl_DStringValue(dsPtr); /* * Check for anchored REs (ie ^foo$), so we can use string equal if * possible. Do not alter the start of str so we can free it correctly. * * Keep track of the last char being an unescaped star to prevent multiple * instances. Simpler than checking that the last star may be escaped. */ msg = NULL; code = NULL; p = reStr; anchorRight = 0; lastIsStar = 0; numStars = 0; if (*p == '^') { anchorLeft = 1; p++; } else { anchorLeft = 0; *dsStr++ = '*'; lastIsStar = 1; } for ( ; p < strEnd; p++) { switch (*p) { case '\\': p++; switch (*p) { case 'a': *dsStr++ = '\a'; break; case 'b': *dsStr++ = '\b'; break; case 'f': *dsStr++ = '\f'; break; case 'n': *dsStr++ = '\n'; break; case 'r': *dsStr++ = '\r'; break; case 't': *dsStr++ = '\t'; break; case 'v': *dsStr++ = '\v'; break; case 'B': case '\\': *dsStr++ = '\\'; *dsStr++ = '\\'; anchorLeft = 0; /* prevent exact match */ break; case '*': case '[': case ']': case '?': /* Only add \ where necessary for glob */ *dsStr++ = '\\'; anchorLeft = 0; /* prevent exact match */ /* fall through */ case '{': case '}': case '(': case ')': case '+': case '.': case '|': case '^': case '$': *dsStr++ = *p; break; default: msg = "invalid escape sequence"; code = "BADESCAPE"; goto invalidGlob; } break; case '.': anchorLeft = 0; /* prevent exact match */ if (p+1 < strEnd) { if (p[1] == '*') { p++; if (!lastIsStar) { *dsStr++ = '*'; lastIsStar = 1; numStars++; } continue; } else if (p[1] == '+') { p++; *dsStr++ = '?'; *dsStr++ = '*'; lastIsStar = 1; numStars++; continue; } } *dsStr++ = '?'; break; case '$': if (p+1 != strEnd) { msg = "$ not anchor"; code = "NONANCHOR"; goto invalidGlob; } anchorRight = 1; break; case '*': case '+': case '?': case '|': case '^': case '{': case '}': case '(': case ')': case '[': case ']': msg = "unhandled RE special char"; code = "UNHANDLED"; goto invalidGlob; default: *dsStr++ = *p; break; } lastIsStar = 0; } if (numStars > 1) { /* * Heuristic: if >1 non-anchoring *, the risk is large that glob * matching is slower than the RE engine, so report invalid. */ msg = "excessive recursive glob backtrack potential"; code = "OVERCOMPLEX"; goto invalidGlob; } if (!anchorRight && !lastIsStar) { *dsStr++ = '*'; } Tcl_DStringSetLength(dsPtr, dsStr - dsStrStart); if (exactPtr) { *exactPtr = (anchorLeft && anchorRight); } #if 0 fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n", reStrLen, reStr, Tcl_DStringValue(dsPtr), anchorLeft, anchorRight); fflush(stderr); #endif return TCL_OK; invalidGlob: #if 0 fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n", reStrLen, reStr, msg, *p); fflush(stderr); #endif if (interp != NULL) { Tcl_AppendResult(interp, msg, NULL); Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL); } Tcl_DStringFree(dsPtr); return TCL_ERROR; } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */