sl@0: /* sl@0: * tclUtil.c -- sl@0: * sl@0: * This file contains utility procedures that are used by many Tcl sl@0: * commands. sl@0: * sl@0: * Copyright (c) 1987-1993 The Regents of the University of California. sl@0: * Copyright (c) 1994-1998 Sun Microsystems, Inc. sl@0: * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclUtil.c,v 1.36.2.8 2007/05/10 18:23:58 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #if defined(__SYMBIAN32__) sl@0: #include "tclSymbianGlobals.h" sl@0: #endif sl@0: sl@0: /* sl@0: * The following variable holds the full path name of the binary sl@0: * from which this application was executed, or NULL if it isn't sl@0: * know. The value of the variable is set by the procedure sl@0: * Tcl_FindExecutable. The storage space is dynamically allocated. sl@0: */ sl@0: sl@0: #if !defined(__SYMBIAN32__) || !defined(__WINSCW__) sl@0: char *tclExecutableName = NULL; sl@0: char *tclNativeExecutableName = NULL; sl@0: #endif sl@0: sl@0: /* sl@0: * The following values are used in the flags returned by Tcl_ScanElement sl@0: * and used by Tcl_ConvertElement. The value TCL_DONT_USE_BRACES is also sl@0: * defined in tcl.h; make sure its value doesn't overlap with any of the sl@0: * values below. sl@0: * sl@0: * TCL_DONT_USE_BRACES - 1 means the string mustn't be enclosed in sl@0: * braces (e.g. it contains unmatched braces, sl@0: * or ends in a backslash character, or user sl@0: * just doesn't want braces); handle all sl@0: * special characters by adding backslashes. sl@0: * USE_BRACES - 1 means the string contains a special sl@0: * character that can be handled simply by sl@0: * enclosing the entire argument in braces. sl@0: * BRACES_UNMATCHED - 1 means that braces aren't properly matched sl@0: * in the argument. sl@0: */ sl@0: sl@0: #define USE_BRACES 2 sl@0: #define BRACES_UNMATCHED 4 sl@0: sl@0: /* sl@0: * The following values determine the precision used when converting sl@0: * floating-point values to strings. This information is linked to all sl@0: * of the tcl_precision variables in all interpreters via the procedure sl@0: * TclPrecTraceProc. sl@0: */ sl@0: sl@0: static char precisionString[10] = "12"; sl@0: /* The string value of all the tcl_precision sl@0: * variables. */ sl@0: static char precisionFormat[10] = "%.12g"; sl@0: /* The format string actually used in calls sl@0: * to sprintf. */ sl@0: TCL_DECLARE_MUTEX(precisionMutex) sl@0: sl@0: /* sl@0: * Prototypes for procedures defined later in this file. sl@0: */ sl@0: sl@0: static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr)); sl@0: static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp, sl@0: Tcl_Obj* objPtr)); sl@0: sl@0: /* sl@0: * The following is the Tcl object type definition for an object sl@0: * that represents a list index in the form, "end-offset". It is sl@0: * used as a performance optimization in TclGetIntForIndex. The sl@0: * internal rep is an integer, so no memory management is required sl@0: * for it. sl@0: */ sl@0: sl@0: Tcl_ObjType tclEndOffsetType = { sl@0: "end-offset", /* name */ sl@0: (Tcl_FreeInternalRepProc*) NULL, /* freeIntRepProc */ sl@0: (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */ sl@0: UpdateStringOfEndOffset, /* updateStringProc */ sl@0: SetEndOffsetFromAny sl@0: }; sl@0: sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFindElement -- sl@0: * sl@0: * Given a pointer into a Tcl list, locate the first (or next) sl@0: * element in the list. sl@0: * sl@0: * Results: sl@0: * The return value is normally TCL_OK, which means that the sl@0: * element was successfully located. If TCL_ERROR is returned sl@0: * it means that list didn't have proper list structure; sl@0: * the interp's result contains a more detailed error message. sl@0: * sl@0: * If TCL_OK is returned, then *elementPtr will be set to point to the sl@0: * first element of list, and *nextPtr will be set to point to the sl@0: * character just after any white space following the last character sl@0: * that's part of the element. If this is the last argument in the sl@0: * list, then *nextPtr will point just after the last character in the sl@0: * list (i.e., at the character at list+listLength). If sizePtr is sl@0: * non-NULL, *sizePtr is filled in with the number of characters in the sl@0: * element. If the element is in braces, then *elementPtr will point sl@0: * to the character after the opening brace and *sizePtr will not sl@0: * include either of the braces. If there isn't an element in the list, sl@0: * *sizePtr will be zero, and both *elementPtr and *termPtr will point sl@0: * just after the last character in the list. Note: this procedure does sl@0: * NOT collapse backslash sequences. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr, sl@0: bracePtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for error reporting. sl@0: * If NULL, then no error message is left sl@0: * after errors. */ sl@0: CONST char *list; /* Points to the first byte of a string sl@0: * containing a Tcl list with zero or more sl@0: * elements (possibly in braces). */ sl@0: int listLength; /* Number of bytes in the list's string. */ sl@0: CONST char **elementPtr; /* Where to put address of first significant sl@0: * character in first element of list. */ sl@0: CONST char **nextPtr; /* Fill in with location of character just sl@0: * after all white space following end of sl@0: * argument (next arg or end of list). */ sl@0: int *sizePtr; /* If non-zero, fill in with size of sl@0: * element. */ sl@0: int *bracePtr; /* If non-zero, fill in with non-zero/zero sl@0: * to indicate that arg was/wasn't sl@0: * in braces. */ sl@0: { sl@0: CONST char *p = list; sl@0: CONST char *elemStart; /* Points to first byte of first element. */ sl@0: CONST char *limit; /* Points just after list's last byte. */ sl@0: int openBraces = 0; /* Brace nesting level during parse. */ sl@0: int inQuotes = 0; sl@0: int size = 0; /* lint. */ sl@0: int numChars; sl@0: CONST char *p2; sl@0: sl@0: /* sl@0: * Skim off leading white space and check for an opening brace or sl@0: * quote. We treat embedded NULLs in the list as bytes belonging to sl@0: * a list element. sl@0: */ sl@0: sl@0: limit = (list + listLength); sl@0: while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ sl@0: p++; sl@0: } sl@0: if (p == limit) { /* no element found */ sl@0: elemStart = limit; sl@0: goto done; sl@0: } sl@0: sl@0: if (*p == '{') { sl@0: openBraces = 1; sl@0: p++; sl@0: } else if (*p == '"') { sl@0: inQuotes = 1; sl@0: p++; sl@0: } sl@0: elemStart = p; sl@0: if (bracePtr != 0) { sl@0: *bracePtr = openBraces; sl@0: } sl@0: sl@0: /* sl@0: * Find element's end (a space, close brace, or the end of the string). sl@0: */ sl@0: sl@0: while (p < limit) { sl@0: switch (*p) { sl@0: sl@0: /* sl@0: * Open brace: don't treat specially unless the element is in sl@0: * braces. In this case, keep a nesting count. sl@0: */ sl@0: sl@0: case '{': sl@0: if (openBraces != 0) { sl@0: openBraces++; sl@0: } sl@0: break; sl@0: sl@0: /* sl@0: * Close brace: if element is in braces, keep nesting count and sl@0: * quit when the last close brace is seen. sl@0: */ sl@0: sl@0: case '}': sl@0: if (openBraces > 1) { sl@0: openBraces--; sl@0: } else if (openBraces == 1) { sl@0: size = (p - elemStart); sl@0: p++; sl@0: if ((p >= limit) sl@0: || isspace(UCHAR(*p))) { /* INTL: ISO space. */ sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Garbage after the closing brace; return an error. sl@0: */ sl@0: sl@0: if (interp != NULL) { sl@0: char buf[100]; sl@0: sl@0: p2 = p; sl@0: while ((p2 < limit) sl@0: && (!isspace(UCHAR(*p2))) /* INTL: ISO space. */ sl@0: && (p2 < p+20)) { sl@0: p2++; sl@0: } sl@0: sprintf(buf, sl@0: "list element in braces followed by \"%.*s\" instead of space", sl@0: (int) (p2-p), p); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: sl@0: /* sl@0: * Backslash: skip over everything up to the end of the sl@0: * backslash sequence. sl@0: */ sl@0: sl@0: case '\\': { sl@0: Tcl_UtfBackslash(p, &numChars, NULL); sl@0: p += (numChars - 1); sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Space: ignore if element is in braces or quotes; otherwise sl@0: * terminate element. sl@0: */ sl@0: sl@0: case ' ': sl@0: case '\f': sl@0: case '\n': sl@0: case '\r': sl@0: case '\t': sl@0: case '\v': sl@0: if ((openBraces == 0) && !inQuotes) { sl@0: size = (p - elemStart); sl@0: goto done; sl@0: } sl@0: break; sl@0: sl@0: /* sl@0: * Double-quote: if element is in quotes then terminate it. sl@0: */ sl@0: sl@0: case '"': sl@0: if (inQuotes) { sl@0: size = (p - elemStart); sl@0: p++; sl@0: if ((p >= limit) sl@0: || isspace(UCHAR(*p))) { /* INTL: ISO space */ sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Garbage after the closing quote; return an error. sl@0: */ sl@0: sl@0: if (interp != NULL) { sl@0: char buf[100]; sl@0: sl@0: p2 = p; sl@0: while ((p2 < limit) sl@0: && (!isspace(UCHAR(*p2))) /* INTL: ISO space */ sl@0: && (p2 < p+20)) { sl@0: p2++; sl@0: } sl@0: sprintf(buf, sl@0: "list element in quotes followed by \"%.*s\" %s", sl@0: (int) (p2-p), p, "instead of space"); sl@0: Tcl_SetResult(interp, buf, TCL_VOLATILE); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: p++; sl@0: } sl@0: sl@0: sl@0: /* sl@0: * End of list: terminate element. sl@0: */ sl@0: sl@0: if (p == limit) { sl@0: if (openBraces != 0) { sl@0: if (interp != NULL) { sl@0: Tcl_SetResult(interp, "unmatched open brace in list", sl@0: TCL_STATIC); sl@0: } sl@0: return TCL_ERROR; sl@0: } else if (inQuotes) { sl@0: if (interp != NULL) { sl@0: Tcl_SetResult(interp, "unmatched open quote in list", sl@0: TCL_STATIC); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: size = (p - elemStart); sl@0: } sl@0: sl@0: done: sl@0: while ((p < limit) && (isspace(UCHAR(*p)))) { /* INTL: ISO space. */ sl@0: p++; sl@0: } sl@0: *elementPtr = elemStart; sl@0: *nextPtr = p; sl@0: if (sizePtr != 0) { sl@0: *sizePtr = size; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCopyAndCollapse -- sl@0: * sl@0: * Copy a string and eliminate any backslashes that aren't in braces. sl@0: * sl@0: * Results: sl@0: * Count characters get copied from src to dst. Along the way, if sl@0: * backslash sequences are found outside braces, the backslashes are sl@0: * eliminated in the copy. After scanning count chars from source, a sl@0: * null character is placed at the end of dst. Returns the number sl@0: * of characters that got copied. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclCopyAndCollapse(count, src, dst) sl@0: int count; /* Number of characters to copy from src. */ sl@0: CONST char *src; /* Copy from here... */ sl@0: char *dst; /* ... to here. */ sl@0: { sl@0: register char c; sl@0: int numRead; sl@0: int newCount = 0; sl@0: int backslashCount; sl@0: sl@0: for (c = *src; count > 0; src++, c = *src, count--) { sl@0: if (c == '\\') { sl@0: backslashCount = Tcl_UtfBackslash(src, &numRead, dst); sl@0: dst += backslashCount; sl@0: newCount += backslashCount; sl@0: src += numRead-1; sl@0: count -= numRead-1; sl@0: } else { sl@0: *dst = c; sl@0: dst++; sl@0: newCount++; sl@0: } sl@0: } sl@0: *dst = 0; sl@0: return newCount; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SplitList -- sl@0: * sl@0: * Splits a list up into its constituent fields. sl@0: * sl@0: * Results sl@0: * The return value is normally TCL_OK, which means that sl@0: * the list was successfully split up. If TCL_ERROR is sl@0: * returned, it means that "list" didn't have proper list sl@0: * structure; the interp's result will contain a more detailed sl@0: * error message. sl@0: * sl@0: * *argvPtr will be filled in with the address of an array sl@0: * whose elements point to the elements of list, in order. sl@0: * *argcPtr will get filled in with the number of valid elements sl@0: * in the array. A single block of memory is dynamically allocated sl@0: * to hold both the argv array and a copy of the list (with sl@0: * backslashes and braces removed in the standard way). sl@0: * The caller must eventually free this memory by calling free() sl@0: * on *argvPtr. Note: *argvPtr and *argcPtr are only modified sl@0: * if the procedure returns normally. sl@0: * sl@0: * Side effects: sl@0: * Memory is allocated. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_SplitList(interp, list, argcPtr, argvPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for error reporting. sl@0: * If NULL, no error message is left. */ sl@0: CONST char *list; /* Pointer to string with list structure. */ sl@0: int *argcPtr; /* Pointer to location to fill in with sl@0: * the number of elements in the list. */ sl@0: CONST char ***argvPtr; /* Pointer to place to store pointer to sl@0: * array of pointers to list elements. */ sl@0: { sl@0: CONST char **argv; sl@0: CONST char *l; sl@0: char *p; sl@0: int length, size, i, result, elSize, brace; sl@0: CONST char *element; sl@0: sl@0: /* sl@0: * Figure out how much space to allocate. There must be enough sl@0: * space for both the array of pointers and also for a copy of sl@0: * the list. To estimate the number of pointers needed, count sl@0: * the number of space characters in the list. sl@0: */ sl@0: sl@0: for (size = 2, l = list; *l != 0; l++) { sl@0: if (isspace(UCHAR(*l))) { /* INTL: ISO space. */ sl@0: size++; sl@0: /* Consecutive space can only count as a single list delimiter */ sl@0: while (1) { sl@0: char next = *(l + 1); sl@0: if (next == '\0') { sl@0: break; sl@0: } sl@0: ++l; sl@0: if (isspace(UCHAR(next))) { sl@0: continue; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: length = l - list; sl@0: argv = (CONST char **) ckalloc((unsigned) sl@0: ((size * sizeof(char *)) + length + 1)); sl@0: for (i = 0, p = ((char *) argv) + size*sizeof(char *); sl@0: *list != 0; i++) { sl@0: CONST char *prevList = list; sl@0: sl@0: result = TclFindElement(interp, list, length, &element, sl@0: &list, &elSize, &brace); sl@0: length -= (list - prevList); sl@0: if (result != TCL_OK) { sl@0: ckfree((char *) argv); sl@0: return result; sl@0: } sl@0: if (*element == 0) { sl@0: break; sl@0: } sl@0: if (i >= size) { sl@0: ckfree((char *) argv); sl@0: if (interp != NULL) { sl@0: Tcl_SetResult(interp, "internal error in Tcl_SplitList", sl@0: TCL_STATIC); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: argv[i] = p; sl@0: if (brace) { sl@0: memcpy((VOID *) p, (VOID *) element, (size_t) elSize); sl@0: p += elSize; sl@0: *p = 0; sl@0: p++; sl@0: } else { sl@0: TclCopyAndCollapse(elSize, element, p); sl@0: p += elSize+1; sl@0: } sl@0: } sl@0: sl@0: argv[i] = NULL; sl@0: *argvPtr = argv; sl@0: *argcPtr = i; sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ScanElement -- sl@0: * sl@0: * This procedure is a companion procedure to Tcl_ConvertElement. sl@0: * It scans a string to see what needs to be done to it (e.g. add sl@0: * backslashes or enclosing braces) to make the string into a sl@0: * valid Tcl list element. sl@0: * sl@0: * Results: sl@0: * The return value is an overestimate of the number of characters sl@0: * that will be needed by Tcl_ConvertElement to produce a valid sl@0: * list element from string. The word at *flagPtr is filled in sl@0: * with a value needed by Tcl_ConvertElement when doing the actual sl@0: * conversion. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ScanElement(string, flagPtr) sl@0: register CONST char *string; /* String to convert to list element. */ sl@0: register int *flagPtr; /* Where to store information to guide sl@0: * Tcl_ConvertCountedElement. */ sl@0: { sl@0: return Tcl_ScanCountedElement(string, -1, flagPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ScanCountedElement -- sl@0: * sl@0: * This procedure is a companion procedure to sl@0: * Tcl_ConvertCountedElement. It scans a string to see what sl@0: * needs to be done to it (e.g. add backslashes or enclosing sl@0: * braces) to make the string into a valid Tcl list element. sl@0: * If length is -1, then the string is scanned up to the first sl@0: * null byte. sl@0: * sl@0: * Results: sl@0: * The return value is an overestimate of the number of characters sl@0: * that will be needed by Tcl_ConvertCountedElement to produce a sl@0: * valid list element from string. The word at *flagPtr is sl@0: * filled in with a value needed by Tcl_ConvertCountedElement sl@0: * when doing the actual conversion. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ScanCountedElement(string, length, flagPtr) sl@0: CONST char *string; /* String to convert to Tcl list element. */ sl@0: int length; /* Number of bytes in string, or -1. */ sl@0: int *flagPtr; /* Where to store information to guide sl@0: * Tcl_ConvertElement. */ sl@0: { sl@0: int flags, nestingLevel; sl@0: register CONST char *p, *lastChar; sl@0: sl@0: /* sl@0: * This procedure and Tcl_ConvertElement together do two things: sl@0: * sl@0: * 1. They produce a proper list, one that will yield back the sl@0: * argument strings when evaluated or when disassembled with sl@0: * Tcl_SplitList. This is the most important thing. sl@0: * sl@0: * 2. They try to produce legible output, which means minimizing the sl@0: * use of backslashes (using braces instead). However, there are sl@0: * some situations where backslashes must be used (e.g. an element sl@0: * like "{abc": the leading brace will have to be backslashed. sl@0: * For each element, one of three things must be done: sl@0: * sl@0: * (a) Use the element as-is (it doesn't contain any special sl@0: * characters). This is the most desirable option. sl@0: * sl@0: * (b) Enclose the element in braces, but leave the contents alone. sl@0: * This happens if the element contains embedded space, or if it sl@0: * contains characters with special interpretation ($, [, ;, or \), sl@0: * or if it starts with a brace or double-quote, or if there are sl@0: * no characters in the element. sl@0: * sl@0: * (c) Don't enclose the element in braces, but add backslashes to sl@0: * prevent special interpretation of special characters. This is a sl@0: * last resort used when the argument would normally fall under case sl@0: * (b) but contains unmatched braces. It also occurs if the last sl@0: * character of the argument is a backslash or if the element contains sl@0: * a backslash followed by newline. sl@0: * sl@0: * The procedure figures out how many bytes will be needed to store sl@0: * the result (actually, it overestimates). It also collects information sl@0: * about the element in the form of a flags word. sl@0: * sl@0: * Note: list elements produced by this procedure and sl@0: * Tcl_ConvertCountedElement must have the property that they can be sl@0: * enclosing in curly braces to make sub-lists. This means, for sl@0: * example, that we must not leave unmatched curly braces in the sl@0: * resulting list element. This property is necessary in order for sl@0: * procedures like Tcl_DStringStartSublist to work. sl@0: */ sl@0: sl@0: nestingLevel = 0; sl@0: flags = 0; sl@0: if (string == NULL) { sl@0: string = ""; sl@0: } sl@0: if (length == -1) { sl@0: length = strlen(string); sl@0: } sl@0: lastChar = string + length; sl@0: p = string; sl@0: if ((p == lastChar) || (*p == '{') || (*p == '"')) { sl@0: flags |= USE_BRACES; sl@0: } sl@0: for ( ; p < lastChar; p++) { sl@0: switch (*p) { sl@0: case '{': sl@0: nestingLevel++; sl@0: break; sl@0: case '}': sl@0: nestingLevel--; sl@0: if (nestingLevel < 0) { sl@0: flags |= TCL_DONT_USE_BRACES|BRACES_UNMATCHED; sl@0: } sl@0: break; sl@0: case '[': sl@0: case '$': sl@0: case ';': sl@0: case ' ': sl@0: case '\f': sl@0: case '\n': sl@0: case '\r': sl@0: case '\t': sl@0: case '\v': sl@0: flags |= USE_BRACES; sl@0: break; sl@0: case '\\': sl@0: if ((p+1 == lastChar) || (p[1] == '\n')) { sl@0: flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; sl@0: } else { sl@0: int size; sl@0: sl@0: Tcl_UtfBackslash(p, &size, NULL); sl@0: p += size-1; sl@0: flags |= USE_BRACES; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: if (nestingLevel != 0) { sl@0: flags = TCL_DONT_USE_BRACES | BRACES_UNMATCHED; sl@0: } sl@0: *flagPtr = flags; sl@0: sl@0: /* sl@0: * Allow enough space to backslash every character plus leave sl@0: * two spaces for braces. sl@0: */ sl@0: sl@0: return 2*(p-string) + 2; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ConvertElement -- sl@0: * sl@0: * This is a companion procedure to Tcl_ScanElement. Given sl@0: * the information produced by Tcl_ScanElement, this procedure sl@0: * converts a string to a list element equal to that string. sl@0: * sl@0: * Results: sl@0: * Information is copied to *dst in the form of a list element sl@0: * identical to src (i.e. if Tcl_SplitList is applied to dst it sl@0: * will produce a string identical to src). The return value is sl@0: * a count of the number of characters copied (not including the sl@0: * terminating NULL character). sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ConvertElement(src, dst, flags) sl@0: register CONST char *src; /* Source information for list element. */ sl@0: register char *dst; /* Place to put list-ified element. */ sl@0: register int flags; /* Flags produced by Tcl_ScanElement. */ sl@0: { sl@0: return Tcl_ConvertCountedElement(src, -1, dst, flags); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ConvertCountedElement -- sl@0: * sl@0: * This is a companion procedure to Tcl_ScanCountedElement. Given sl@0: * the information produced by Tcl_ScanCountedElement, this sl@0: * procedure converts a string to a list element equal to that sl@0: * string. sl@0: * sl@0: * Results: sl@0: * Information is copied to *dst in the form of a list element sl@0: * identical to src (i.e. if Tcl_SplitList is applied to dst it sl@0: * will produce a string identical to src). The return value is sl@0: * a count of the number of characters copied (not including the sl@0: * terminating NULL character). sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ConvertCountedElement(src, length, dst, flags) sl@0: register CONST char *src; /* Source information for list element. */ sl@0: int length; /* Number of bytes in src, or -1. */ sl@0: char *dst; /* Place to put list-ified element. */ sl@0: int flags; /* Flags produced by Tcl_ScanElement. */ sl@0: { sl@0: register char *p = dst; sl@0: register CONST char *lastChar; sl@0: sl@0: /* sl@0: * See the comment block at the beginning of the Tcl_ScanElement sl@0: * code for details of how this works. sl@0: */ sl@0: sl@0: if (src && length == -1) { sl@0: length = strlen(src); sl@0: } sl@0: if ((src == NULL) || (length == 0)) { sl@0: p[0] = '{'; sl@0: p[1] = '}'; sl@0: p[2] = 0; sl@0: return 2; sl@0: } sl@0: lastChar = src + length; sl@0: if ((flags & USE_BRACES) && !(flags & TCL_DONT_USE_BRACES)) { sl@0: *p = '{'; sl@0: p++; sl@0: for ( ; src != lastChar; src++, p++) { sl@0: *p = *src; sl@0: } sl@0: *p = '}'; sl@0: p++; sl@0: } else { sl@0: if (*src == '{') { sl@0: /* sl@0: * Can't have a leading brace unless the whole element is sl@0: * enclosed in braces. Add a backslash before the brace. sl@0: * Furthermore, this may destroy the balance between open sl@0: * and close braces, so set BRACES_UNMATCHED. sl@0: */ sl@0: sl@0: p[0] = '\\'; sl@0: p[1] = '{'; sl@0: p += 2; sl@0: src++; sl@0: flags |= BRACES_UNMATCHED; sl@0: } sl@0: for (; src != lastChar; src++) { sl@0: switch (*src) { sl@0: case ']': sl@0: case '[': sl@0: case '$': sl@0: case ';': sl@0: case ' ': sl@0: case '\\': sl@0: case '"': sl@0: *p = '\\'; sl@0: p++; sl@0: break; sl@0: case '{': sl@0: case '}': sl@0: /* sl@0: * It may not seem necessary to backslash braces, but sl@0: * it is. The reason for this is that the resulting sl@0: * list element may actually be an element of a sub-list sl@0: * enclosed in braces (e.g. if Tcl_DStringStartSublist sl@0: * has been invoked), so there may be a brace mismatch sl@0: * if the braces aren't backslashed. sl@0: */ sl@0: sl@0: if (flags & BRACES_UNMATCHED) { sl@0: *p = '\\'; sl@0: p++; sl@0: } sl@0: break; sl@0: case '\f': sl@0: *p = '\\'; sl@0: p++; sl@0: *p = 'f'; sl@0: p++; sl@0: continue; sl@0: case '\n': sl@0: *p = '\\'; sl@0: p++; sl@0: *p = 'n'; sl@0: p++; sl@0: continue; sl@0: case '\r': sl@0: *p = '\\'; sl@0: p++; sl@0: *p = 'r'; sl@0: p++; sl@0: continue; sl@0: case '\t': sl@0: *p = '\\'; sl@0: p++; sl@0: *p = 't'; sl@0: p++; sl@0: continue; sl@0: case '\v': sl@0: *p = '\\'; sl@0: p++; sl@0: *p = 'v'; sl@0: p++; sl@0: continue; sl@0: } sl@0: *p = *src; sl@0: p++; sl@0: } sl@0: } sl@0: *p = '\0'; sl@0: return p-dst; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Merge -- sl@0: * sl@0: * Given a collection of strings, merge them together into a sl@0: * single string that has proper Tcl list structured (i.e. sl@0: * Tcl_SplitList may be used to retrieve strings equal to the sl@0: * original elements, and Tcl_Eval will parse the string back sl@0: * into its original elements). sl@0: * sl@0: * Results: sl@0: * The return value is the address of a dynamically-allocated sl@0: * string containing the merged list. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_Merge(argc, argv) sl@0: int argc; /* How many strings to merge. */ sl@0: CONST char * CONST *argv; /* Array of string values. */ sl@0: { sl@0: # define LOCAL_SIZE 20 sl@0: int localFlags[LOCAL_SIZE], *flagPtr; sl@0: int numChars; sl@0: char *result; sl@0: char *dst; sl@0: int i; sl@0: sl@0: /* sl@0: * Pass 1: estimate space, gather flags. sl@0: */ sl@0: sl@0: if (argc <= LOCAL_SIZE) { sl@0: flagPtr = localFlags; sl@0: } else { sl@0: flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int)); sl@0: } sl@0: numChars = 1; sl@0: for (i = 0; i < argc; i++) { sl@0: numChars += Tcl_ScanElement(argv[i], &flagPtr[i]) + 1; sl@0: } sl@0: sl@0: /* sl@0: * Pass two: copy into the result area. sl@0: */ sl@0: sl@0: result = (char *) ckalloc((unsigned) numChars); sl@0: dst = result; sl@0: for (i = 0; i < argc; i++) { sl@0: numChars = Tcl_ConvertElement(argv[i], dst, flagPtr[i]); sl@0: dst += numChars; sl@0: *dst = ' '; sl@0: dst++; sl@0: } sl@0: if (dst == result) { sl@0: *dst = 0; sl@0: } else { sl@0: dst[-1] = 0; sl@0: } sl@0: sl@0: if (flagPtr != localFlags) { sl@0: ckfree((char *) flagPtr); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Backslash -- sl@0: * sl@0: * Figure out how to handle a backslash sequence. sl@0: * sl@0: * Results: sl@0: * The return value is the character that should be substituted sl@0: * in place of the backslash sequence that starts at src. If sl@0: * readPtr isn't NULL then it is filled in with a count of the sl@0: * number of characters in the backslash sequence. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char sl@0: Tcl_Backslash(src, readPtr) sl@0: CONST char *src; /* Points to the backslash character of sl@0: * a backslash sequence. */ sl@0: int *readPtr; /* Fill in with number of characters read sl@0: * from src, unless NULL. */ sl@0: { sl@0: char buf[TCL_UTF_MAX]; sl@0: Tcl_UniChar ch; sl@0: sl@0: Tcl_UtfBackslash(src, readPtr, buf); sl@0: TclUtfToUniChar(buf, &ch); sl@0: return (char) ch; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_Concat -- sl@0: * sl@0: * Concatenate a set of strings into a single large string. sl@0: * sl@0: * Results: sl@0: * The return value is dynamically-allocated string containing sl@0: * a concatenation of all the strings in argv, with spaces between sl@0: * the original argv elements. sl@0: * sl@0: * Side effects: sl@0: * Memory is allocated for the result; the caller is responsible sl@0: * for freeing the memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_Concat(argc, argv) sl@0: int argc; /* Number of strings to concatenate. */ sl@0: CONST char * CONST *argv; /* Array of strings to concatenate. */ sl@0: { sl@0: int totalSize, i; sl@0: char *p; sl@0: char *result; sl@0: sl@0: for (totalSize = 1, i = 0; i < argc; i++) { sl@0: totalSize += strlen(argv[i]) + 1; sl@0: } sl@0: result = (char *) ckalloc((unsigned) totalSize); sl@0: if (argc == 0) { sl@0: *result = '\0'; sl@0: return result; sl@0: } sl@0: for (p = result, i = 0; i < argc; i++) { sl@0: CONST char *element; sl@0: int length; sl@0: sl@0: /* sl@0: * Clip white space off the front and back of the string sl@0: * to generate a neater result, and ignore any empty sl@0: * elements. sl@0: */ sl@0: sl@0: element = argv[i]; sl@0: while (isspace(UCHAR(*element))) { /* INTL: ISO space. */ sl@0: element++; sl@0: } sl@0: for (length = strlen(element); sl@0: (length > 0) sl@0: && (isspace(UCHAR(element[length-1]))) /* INTL: ISO space. */ sl@0: && ((length < 2) || (element[length-2] != '\\')); sl@0: length--) { sl@0: /* Null loop body. */ sl@0: } sl@0: if (length == 0) { sl@0: continue; sl@0: } sl@0: memcpy((VOID *) p, (VOID *) element, (size_t) length); sl@0: p += length; sl@0: *p = ' '; sl@0: p++; sl@0: } sl@0: if (p != result) { sl@0: p[-1] = 0; sl@0: } else { sl@0: *p = 0; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_ConcatObj -- sl@0: * sl@0: * Concatenate the strings from a set of objects into a single string sl@0: * object with spaces between the original strings. sl@0: * sl@0: * Results: sl@0: * The return value is a new string object containing a concatenation sl@0: * of the strings in objv. Its ref count is zero. sl@0: * sl@0: * Side effects: sl@0: * A new object is created. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_ConcatObj(objc, objv) sl@0: int objc; /* Number of objects to concatenate. */ sl@0: Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */ sl@0: { sl@0: int allocSize, finalSize, length, elemLength, i; sl@0: char *p; sl@0: char *element; sl@0: char *concatStr; sl@0: Tcl_Obj *objPtr; sl@0: sl@0: /* sl@0: * Check first to see if all the items are of list type. If so, sl@0: * we will concat them together as lists, and return a list object. sl@0: * This is only valid when the lists have no current string sl@0: * representation, since we don't know what the original type was. sl@0: * An original string rep may have lost some whitespace info when sl@0: * converted which could be important. sl@0: */ sl@0: for (i = 0; i < objc; i++) { sl@0: objPtr = objv[i]; sl@0: if ((objPtr->typePtr != &tclListType) || (objPtr->bytes != NULL)) { sl@0: break; sl@0: } sl@0: } sl@0: if (i == objc) { sl@0: Tcl_Obj **listv; sl@0: int listc; sl@0: sl@0: objPtr = Tcl_NewListObj(0, NULL); sl@0: for (i = 0; i < objc; i++) { sl@0: /* sl@0: * Tcl_ListObjAppendList could be used here, but this saves sl@0: * us a bit of type checking (since we've already done it) sl@0: * Use of INT_MAX tells us to always put the new stuff on sl@0: * the end. It will be set right in Tcl_ListObjReplace. sl@0: */ sl@0: Tcl_ListObjGetElements(NULL, objv[i], &listc, &listv); sl@0: Tcl_ListObjReplace(NULL, objPtr, INT_MAX, 0, listc, listv); sl@0: } sl@0: return objPtr; sl@0: } sl@0: sl@0: allocSize = 0; sl@0: for (i = 0; i < objc; i++) { sl@0: objPtr = objv[i]; sl@0: element = Tcl_GetStringFromObj(objPtr, &length); sl@0: if ((element != NULL) && (length > 0)) { sl@0: allocSize += (length + 1); sl@0: } sl@0: } sl@0: if (allocSize == 0) { sl@0: allocSize = 1; /* enough for the NULL byte at end */ sl@0: } sl@0: sl@0: /* sl@0: * Allocate storage for the concatenated result. Note that allocSize sl@0: * is one more than the total number of characters, and so includes sl@0: * room for the terminating NULL byte. sl@0: */ sl@0: sl@0: concatStr = (char *) ckalloc((unsigned) allocSize); sl@0: sl@0: /* sl@0: * Now concatenate the elements. Clip white space off the front and back sl@0: * to generate a neater result, and ignore any empty elements. Also put sl@0: * a null byte at the end. sl@0: */ sl@0: sl@0: finalSize = 0; sl@0: if (objc == 0) { sl@0: *concatStr = '\0'; sl@0: } else { sl@0: p = concatStr; sl@0: for (i = 0; i < objc; i++) { sl@0: objPtr = objv[i]; sl@0: element = Tcl_GetStringFromObj(objPtr, &elemLength); sl@0: while ((elemLength > 0) && (UCHAR(*element) < 127) sl@0: && isspace(UCHAR(*element))) { /* INTL: ISO C space. */ sl@0: element++; sl@0: elemLength--; sl@0: } sl@0: sl@0: /* sl@0: * Trim trailing white space. But, be careful not to trim sl@0: * a space character if it is preceded by a backslash: in sl@0: * this case it could be significant. sl@0: */ sl@0: sl@0: while ((elemLength > 0) && (UCHAR(element[elemLength-1]) < 127) sl@0: && isspace(UCHAR(element[elemLength-1])) /* INTL: ISO C space. */ sl@0: && ((elemLength < 2) || (element[elemLength-2] != '\\'))) { sl@0: elemLength--; sl@0: } sl@0: if (elemLength == 0) { sl@0: continue; /* nothing left of this element */ sl@0: } sl@0: memcpy((VOID *) p, (VOID *) element, (size_t) elemLength); sl@0: p += elemLength; sl@0: *p = ' '; sl@0: p++; sl@0: finalSize += (elemLength + 1); sl@0: } sl@0: if (p != concatStr) { sl@0: p[-1] = 0; sl@0: finalSize -= 1; /* we overwrote the final ' ' */ sl@0: } else { sl@0: *p = 0; sl@0: } sl@0: } sl@0: sl@0: TclNewObj(objPtr); sl@0: objPtr->bytes = concatStr; sl@0: objPtr->length = finalSize; sl@0: return objPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_StringMatch -- sl@0: * sl@0: * See if a particular string matches a particular pattern. sl@0: * sl@0: * Results: sl@0: * The return value is 1 if string matches pattern, and sl@0: * 0 otherwise. The matching operation permits the following sl@0: * special characters in the pattern: *?\[] (see the manual sl@0: * entry for details on what these mean). sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_StringMatch(string, pattern) sl@0: CONST char *string; /* String. */ sl@0: CONST char *pattern; /* Pattern, which may contain special sl@0: * characters. */ sl@0: { sl@0: return Tcl_StringCaseMatch(string, pattern, 0); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_StringCaseMatch -- sl@0: * sl@0: * See if a particular string matches a particular pattern. sl@0: * Allows case insensitivity. sl@0: * sl@0: * Results: sl@0: * The return value is 1 if string matches pattern, and sl@0: * 0 otherwise. The matching operation permits the following sl@0: * special characters in the pattern: *?\[] (see the manual sl@0: * entry for details on what these mean). sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_StringCaseMatch(string, pattern, nocase) sl@0: CONST char *string; /* String. */ sl@0: CONST char *pattern; /* Pattern, which may contain special sl@0: * characters. */ sl@0: int nocase; /* 0 for case sensitive, 1 for insensitive */ sl@0: { sl@0: int p, charLen; sl@0: CONST char *pstart = pattern; sl@0: Tcl_UniChar ch1, ch2; sl@0: sl@0: while (1) { sl@0: p = *pattern; sl@0: sl@0: /* sl@0: * See if we're at the end of both the pattern and the string. If sl@0: * so, we succeeded. If we're at the end of the pattern but not at sl@0: * the end of the string, we failed. sl@0: */ sl@0: sl@0: if (p == '\0') { sl@0: return (*string == '\0'); sl@0: } sl@0: if ((*string == '\0') && (p != '*')) { sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * Check for a "*" as the next pattern character. It matches sl@0: * any substring. We handle this by calling ourselves sl@0: * recursively for each postfix of string, until either we sl@0: * match or we reach the end of the string. sl@0: */ sl@0: sl@0: if (p == '*') { sl@0: /* sl@0: * Skip all successive *'s in the pattern sl@0: */ sl@0: while (*(++pattern) == '*') {} sl@0: p = *pattern; sl@0: if (p == '\0') { sl@0: return 1; sl@0: } sl@0: /* sl@0: * This is a special case optimization for single-byte utf. sl@0: */ sl@0: if (UCHAR(*pattern) < 0x80) { sl@0: ch2 = (Tcl_UniChar) sl@0: (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); sl@0: } else { sl@0: Tcl_UtfToUniChar(pattern, &ch2); sl@0: if (nocase) { sl@0: ch2 = Tcl_UniCharToLower(ch2); sl@0: } sl@0: } sl@0: while (1) { sl@0: /* sl@0: * Optimization for matching - cruise through the string sl@0: * quickly if the next char in the pattern isn't a special sl@0: * character sl@0: */ sl@0: if ((p != '[') && (p != '?') && (p != '\\')) { sl@0: if (nocase) { sl@0: while (*string) { sl@0: charLen = TclUtfToUniChar(string, &ch1); sl@0: if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { sl@0: break; sl@0: } sl@0: string += charLen; sl@0: } sl@0: } else { sl@0: /* sl@0: * There's no point in trying to make this code sl@0: * shorter, as the number of bytes you want to sl@0: * compare each time is non-constant. sl@0: */ sl@0: while (*string) { sl@0: charLen = TclUtfToUniChar(string, &ch1); sl@0: if (ch2 == ch1) { sl@0: break; sl@0: } sl@0: string += charLen; sl@0: } sl@0: } sl@0: } sl@0: if (Tcl_StringCaseMatch(string, pattern, nocase)) { sl@0: return 1; sl@0: } sl@0: if (*string == '\0') { sl@0: return 0; sl@0: } sl@0: string += TclUtfToUniChar(string, &ch1); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Check for a "?" as the next pattern character. It matches sl@0: * any single character. sl@0: */ sl@0: sl@0: if (p == '?') { sl@0: pattern++; sl@0: string += TclUtfToUniChar(string, &ch1); sl@0: continue; sl@0: } sl@0: sl@0: /* sl@0: * Check for a "[" as the next pattern character. It is followed sl@0: * by a list of characters that are acceptable, or by a range sl@0: * (two characters separated by "-"). sl@0: */ sl@0: sl@0: if (p == '[') { sl@0: Tcl_UniChar startChar, endChar; sl@0: sl@0: pattern++; sl@0: if (UCHAR(*string) < 0x80) { sl@0: ch1 = (Tcl_UniChar) sl@0: (nocase ? tolower(UCHAR(*string)) : UCHAR(*string)); sl@0: string++; sl@0: } else { sl@0: string += Tcl_UtfToUniChar(string, &ch1); sl@0: if (nocase) { sl@0: ch1 = Tcl_UniCharToLower(ch1); sl@0: } sl@0: } sl@0: while (1) { sl@0: if ((*pattern == ']') || (*pattern == '\0')) { sl@0: return 0; sl@0: } sl@0: if (UCHAR(*pattern) < 0x80) { sl@0: startChar = (Tcl_UniChar) sl@0: (nocase ? tolower(UCHAR(*pattern)) : UCHAR(*pattern)); sl@0: pattern++; sl@0: } else { sl@0: pattern += Tcl_UtfToUniChar(pattern, &startChar); sl@0: if (nocase) { sl@0: startChar = Tcl_UniCharToLower(startChar); sl@0: } sl@0: } sl@0: if (*pattern == '-') { sl@0: pattern++; sl@0: if (*pattern == '\0') { sl@0: return 0; sl@0: } sl@0: if (UCHAR(*pattern) < 0x80) { sl@0: endChar = (Tcl_UniChar) sl@0: (nocase ? tolower(UCHAR(*pattern)) sl@0: : UCHAR(*pattern)); sl@0: pattern++; sl@0: } else { sl@0: pattern += Tcl_UtfToUniChar(pattern, &endChar); sl@0: if (nocase) { sl@0: endChar = Tcl_UniCharToLower(endChar); sl@0: } sl@0: } sl@0: if (((startChar <= ch1) && (ch1 <= endChar)) sl@0: || ((endChar <= ch1) && (ch1 <= startChar))) { sl@0: /* sl@0: * Matches ranges of form [a-z] or [z-a]. sl@0: */ sl@0: sl@0: break; sl@0: } sl@0: } else if (startChar == ch1) { sl@0: break; sl@0: } sl@0: } sl@0: while (*pattern != ']') { sl@0: if (*pattern == '\0') { sl@0: pattern = Tcl_UtfPrev(pattern, pstart); sl@0: break; sl@0: } sl@0: pattern++; sl@0: } sl@0: pattern++; sl@0: continue; sl@0: } sl@0: sl@0: /* sl@0: * If the next pattern character is '\', just strip off the '\' sl@0: * so we do exact matching on the character that follows. sl@0: */ sl@0: sl@0: if (p == '\\') { sl@0: pattern++; sl@0: if (*pattern == '\0') { sl@0: return 0; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * There's no special character. Just make sure that the next sl@0: * bytes of each string match. sl@0: */ sl@0: sl@0: string += TclUtfToUniChar(string, &ch1); sl@0: pattern += TclUtfToUniChar(pattern, &ch2); sl@0: if (nocase) { sl@0: if (Tcl_UniCharToLower(ch1) != Tcl_UniCharToLower(ch2)) { sl@0: return 0; sl@0: } sl@0: } else if (ch1 != ch2) { sl@0: return 0; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclMatchIsTrivial -- sl@0: * sl@0: * Test whether a particular glob pattern is a trivial pattern. sl@0: * (i.e. where matching is the same as equality testing). sl@0: * sl@0: * Results: sl@0: * A boolean indicating whether the pattern is free of all of the sl@0: * glob special chars. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclMatchIsTrivial(pattern) sl@0: CONST char *pattern; sl@0: { sl@0: CONST char *p = pattern; sl@0: sl@0: while (1) { sl@0: switch (*p++) { sl@0: case '\0': sl@0: return 1; sl@0: case '*': sl@0: case '?': sl@0: case '[': sl@0: case '\\': sl@0: return 0; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringInit -- sl@0: * sl@0: * Initializes a dynamic string, discarding any previous contents sl@0: * of the string (Tcl_DStringFree should have been called already sl@0: * if the dynamic string was previously in use). sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The dynamic string is initialized to be empty. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringInit(dsPtr) sl@0: Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */ sl@0: { sl@0: dsPtr->string = dsPtr->staticSpace; sl@0: dsPtr->length = 0; sl@0: dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; sl@0: dsPtr->staticSpace[0] = '\0'; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringAppend -- sl@0: * sl@0: * Append more characters to the current value of a dynamic string. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the dynamic string's new value. sl@0: * sl@0: * Side effects: sl@0: * Length bytes from string (or all of string if length is less sl@0: * than zero) are added to the current value of the string. Memory sl@0: * gets reallocated if needed to accomodate the string's new size. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_DStringAppend(dsPtr, string, length) sl@0: Tcl_DString *dsPtr; /* Structure describing dynamic string. */ sl@0: CONST char *string; /* String to append. If length is -1 then sl@0: * this must be null-terminated. */ sl@0: int length; /* Number of characters from string to sl@0: * append. If < 0, then append all of string, sl@0: * up to null at end. */ sl@0: { sl@0: int newSize; sl@0: char *dst; sl@0: CONST char *end; sl@0: sl@0: if (length < 0) { sl@0: length = strlen(string); sl@0: } sl@0: newSize = length + dsPtr->length; sl@0: sl@0: /* sl@0: * Allocate a larger buffer for the string if the current one isn't sl@0: * large enough. Allocate extra space in the new buffer so that there sl@0: * will be room to grow before we have to allocate again. sl@0: */ sl@0: sl@0: if (newSize >= dsPtr->spaceAvl) { sl@0: dsPtr->spaceAvl = newSize * 2; sl@0: if (dsPtr->string == dsPtr->staticSpace) { sl@0: char *newString; sl@0: sl@0: newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); sl@0: memcpy((VOID *) newString, (VOID *) dsPtr->string, sl@0: (size_t) dsPtr->length); sl@0: dsPtr->string = newString; sl@0: } else { sl@0: dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, sl@0: (size_t) dsPtr->spaceAvl); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Copy the new string into the buffer at the end of the old sl@0: * one. sl@0: */ sl@0: sl@0: for (dst = dsPtr->string + dsPtr->length, end = string+length; sl@0: string < end; string++, dst++) { sl@0: *dst = *string; sl@0: } sl@0: *dst = '\0'; sl@0: dsPtr->length += length; sl@0: return dsPtr->string; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringAppendElement -- sl@0: * sl@0: * Append a list element to the current value of a dynamic string. sl@0: * sl@0: * Results: sl@0: * The return value is a pointer to the dynamic string's new value. sl@0: * sl@0: * Side effects: sl@0: * String is reformatted as a list element and added to the current sl@0: * value of the string. Memory gets reallocated if needed to sl@0: * accomodate the string's new size. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C char * sl@0: Tcl_DStringAppendElement(dsPtr, string) sl@0: Tcl_DString *dsPtr; /* Structure describing dynamic string. */ sl@0: CONST char *string; /* String to append. Must be sl@0: * null-terminated. */ sl@0: { sl@0: int newSize, flags, strSize; sl@0: char *dst; sl@0: sl@0: strSize = ((string == NULL) ? 0 : strlen(string)); sl@0: newSize = Tcl_ScanCountedElement(string, strSize, &flags) sl@0: + dsPtr->length + 1; sl@0: sl@0: /* sl@0: * Allocate a larger buffer for the string if the current one isn't sl@0: * large enough. Allocate extra space in the new buffer so that there sl@0: * will be room to grow before we have to allocate again. sl@0: * SPECIAL NOTE: must use memcpy, not strcpy, to copy the string sl@0: * to a larger buffer, since there may be embedded NULLs in the sl@0: * string in some cases. sl@0: */ sl@0: sl@0: if (newSize >= dsPtr->spaceAvl) { sl@0: dsPtr->spaceAvl = newSize * 2; sl@0: if (dsPtr->string == dsPtr->staticSpace) { sl@0: char *newString; sl@0: sl@0: newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); sl@0: memcpy((VOID *) newString, (VOID *) dsPtr->string, sl@0: (size_t) dsPtr->length); sl@0: dsPtr->string = newString; sl@0: } else { sl@0: dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, sl@0: (size_t) dsPtr->spaceAvl); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Convert the new string to a list element and copy it into the sl@0: * buffer at the end, with a space, if needed. sl@0: */ sl@0: sl@0: dst = dsPtr->string + dsPtr->length; sl@0: if (TclNeedSpace(dsPtr->string, dst)) { sl@0: *dst = ' '; sl@0: dst++; sl@0: dsPtr->length++; sl@0: } sl@0: dsPtr->length += Tcl_ConvertCountedElement(string, strSize, dst, flags); sl@0: return dsPtr->string; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringSetLength -- sl@0: * sl@0: * Change the length of a dynamic string. This can cause the sl@0: * string to either grow or shrink, depending on the value of sl@0: * length. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The length of dsPtr is changed to length and a null byte is sl@0: * stored at that position in the string. If length is larger sl@0: * than the space allocated for dsPtr, then a panic occurs. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringSetLength(dsPtr, length) sl@0: Tcl_DString *dsPtr; /* Structure describing dynamic string. */ sl@0: int length; /* New length for dynamic string. */ sl@0: { sl@0: int newsize; sl@0: sl@0: if (length < 0) { sl@0: length = 0; sl@0: } sl@0: if (length >= dsPtr->spaceAvl) { sl@0: /* sl@0: * There are two interesting cases here. In the first case, the user sl@0: * may be trying to allocate a large buffer of a specific size. It sl@0: * would be wasteful to overallocate that buffer, so we just allocate sl@0: * enough for the requested size plus the trailing null byte. In the sl@0: * second case, we are growing the buffer incrementally, so we need sl@0: * behavior similar to Tcl_DStringAppend. The requested length will sl@0: * usually be a small delta above the current spaceAvl, so we'll end up sl@0: * doubling the old size. This won't grow the buffer quite as quickly, sl@0: * but it should be close enough. sl@0: */ sl@0: sl@0: newsize = dsPtr->spaceAvl * 2; sl@0: if (length < newsize) { sl@0: dsPtr->spaceAvl = newsize; sl@0: } else { sl@0: dsPtr->spaceAvl = length + 1; sl@0: } sl@0: if (dsPtr->string == dsPtr->staticSpace) { sl@0: char *newString; sl@0: sl@0: newString = (char *) ckalloc((unsigned) dsPtr->spaceAvl); sl@0: memcpy((VOID *) newString, (VOID *) dsPtr->string, sl@0: (size_t) dsPtr->length); sl@0: dsPtr->string = newString; sl@0: } else { sl@0: dsPtr->string = (char *) ckrealloc((VOID *) dsPtr->string, sl@0: (size_t) dsPtr->spaceAvl); sl@0: } sl@0: } sl@0: dsPtr->length = length; sl@0: dsPtr->string[length] = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringFree -- sl@0: * sl@0: * Frees up any memory allocated for the dynamic string and sl@0: * reinitializes the string to an empty state. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The previous contents of the dynamic string are lost, and sl@0: * the new value is an empty string. sl@0: * sl@0: *---------------------------------------------------------------------- */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringFree(dsPtr) sl@0: Tcl_DString *dsPtr; /* Structure describing dynamic string. */ sl@0: { sl@0: if (dsPtr->string != dsPtr->staticSpace) { sl@0: ckfree(dsPtr->string); sl@0: } sl@0: dsPtr->string = dsPtr->staticSpace; sl@0: dsPtr->length = 0; sl@0: dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; sl@0: dsPtr->staticSpace[0] = '\0'; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringResult -- sl@0: * sl@0: * This procedure moves the value of a dynamic string into an sl@0: * interpreter as its string result. Afterwards, the dynamic string sl@0: * is reset to an empty string. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The string is "moved" to interp's result, and any existing sl@0: * string result for interp is freed. dsPtr is reinitialized to sl@0: * an empty string. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringResult(interp, dsPtr) sl@0: Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ sl@0: Tcl_DString *dsPtr; /* Dynamic string that is to become the sl@0: * result of interp. */ sl@0: { sl@0: Tcl_ResetResult(interp); sl@0: sl@0: if (dsPtr->string != dsPtr->staticSpace) { sl@0: interp->result = dsPtr->string; sl@0: interp->freeProc = TCL_DYNAMIC; sl@0: } else if (dsPtr->length < TCL_RESULT_SIZE) { sl@0: interp->result = ((Interp *) interp)->resultSpace; sl@0: strcpy(interp->result, dsPtr->string); sl@0: } else { sl@0: Tcl_SetResult(interp, dsPtr->string, TCL_VOLATILE); sl@0: } sl@0: sl@0: dsPtr->string = dsPtr->staticSpace; sl@0: dsPtr->length = 0; sl@0: dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; sl@0: dsPtr->staticSpace[0] = '\0'; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringGetResult -- sl@0: * sl@0: * This procedure moves an interpreter's result into a dynamic string. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The interpreter's string result is cleared, and the previous sl@0: * contents of dsPtr are freed. sl@0: * sl@0: * If the string result is empty, the object result is moved to the sl@0: * string result, then the object result is reset. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringGetResult(interp, dsPtr) sl@0: Tcl_Interp *interp; /* Interpreter whose result is to be reset. */ sl@0: Tcl_DString *dsPtr; /* Dynamic string that is to become the sl@0: * result of interp. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: sl@0: if (dsPtr->string != dsPtr->staticSpace) { sl@0: ckfree(dsPtr->string); sl@0: } sl@0: sl@0: /* sl@0: * If the string result is empty, move the object result to the sl@0: * string result, then reset the object result. sl@0: */ sl@0: sl@0: if (*(iPtr->result) == 0) { sl@0: Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)), sl@0: TCL_VOLATILE); sl@0: } sl@0: sl@0: dsPtr->length = strlen(iPtr->result); sl@0: if (iPtr->freeProc != NULL) { sl@0: if (iPtr->freeProc == TCL_DYNAMIC) { sl@0: dsPtr->string = iPtr->result; sl@0: dsPtr->spaceAvl = dsPtr->length+1; sl@0: } else { sl@0: dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length+1)); sl@0: strcpy(dsPtr->string, iPtr->result); sl@0: (*iPtr->freeProc)(iPtr->result); sl@0: } sl@0: dsPtr->spaceAvl = dsPtr->length+1; sl@0: iPtr->freeProc = NULL; sl@0: } else { sl@0: if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { sl@0: dsPtr->string = dsPtr->staticSpace; sl@0: dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; sl@0: } else { sl@0: dsPtr->string = (char *) ckalloc((unsigned) (dsPtr->length + 1)); sl@0: dsPtr->spaceAvl = dsPtr->length + 1; sl@0: } sl@0: strcpy(dsPtr->string, iPtr->result); sl@0: } sl@0: sl@0: iPtr->result = iPtr->resultSpace; sl@0: iPtr->resultSpace[0] = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringStartSublist -- sl@0: * sl@0: * This procedure adds the necessary information to a dynamic sl@0: * string (e.g. " {" to start a sublist. Future element sl@0: * appends will be in the sublist rather than the main list. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Characters get added to the dynamic string. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringStartSublist(dsPtr) sl@0: Tcl_DString *dsPtr; /* Dynamic string. */ sl@0: { sl@0: if (TclNeedSpace(dsPtr->string, dsPtr->string + dsPtr->length)) { sl@0: Tcl_DStringAppend(dsPtr, " {", -1); sl@0: } else { sl@0: Tcl_DStringAppend(dsPtr, "{", -1); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DStringEndSublist -- sl@0: * sl@0: * This procedure adds the necessary characters to a dynamic sl@0: * string to end a sublist (e.g. "}"). Future element appends sl@0: * will be in the enclosing (sub)list rather than the current sl@0: * sublist. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_DStringEndSublist(dsPtr) sl@0: Tcl_DString *dsPtr; /* Dynamic string. */ sl@0: { sl@0: Tcl_DStringAppend(dsPtr, "}", -1); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_PrintDouble -- sl@0: * sl@0: * Given a floating-point value, this procedure converts it to sl@0: * an ASCII string using. sl@0: * sl@0: * Results: sl@0: * The ASCII equivalent of "value" is written at "dst". It is sl@0: * written using the current precision, and it is guaranteed to sl@0: * contain a decimal point or exponent, so that it looks like sl@0: * a floating-point value and not an integer. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_PrintDouble(interp, value, dst) sl@0: Tcl_Interp *interp; /* Interpreter whose tcl_precision sl@0: * variable used to be used to control sl@0: * printing. It's ignored now. */ sl@0: double value; /* Value to print as string. */ sl@0: char *dst; /* Where to store converted value; sl@0: * must have at least TCL_DOUBLE_SPACE sl@0: * characters. */ sl@0: { sl@0: char *p, c; sl@0: Tcl_UniChar ch; sl@0: sl@0: Tcl_MutexLock(&precisionMutex); sl@0: sprintf(dst, precisionFormat, value); sl@0: Tcl_MutexUnlock(&precisionMutex); sl@0: sl@0: /* sl@0: * If the ASCII result looks like an integer, add ".0" so that it sl@0: * doesn't look like an integer anymore. This prevents floating-point sl@0: * values from being converted to integers unintentionally. sl@0: * Check for ASCII specifically to speed up the function. sl@0: */ sl@0: sl@0: for (p = dst; *p != 0; ) { sl@0: if (UCHAR(*p) < 0x80) { sl@0: c = *p++; sl@0: } else { sl@0: p += Tcl_UtfToUniChar(p, &ch); sl@0: c = UCHAR(ch); sl@0: } sl@0: if ((c == '.') || isalpha(UCHAR(c))) { /* INTL: ISO only. */ sl@0: return; sl@0: } sl@0: } sl@0: p[0] = '.'; sl@0: p[1] = '0'; sl@0: p[2] = 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclPrecTraceProc -- sl@0: * sl@0: * This procedure is invoked whenever the variable "tcl_precision" sl@0: * is written. sl@0: * sl@0: * Results: sl@0: * Returns NULL if all went well, or an error message if the sl@0: * new value for the variable doesn't make sense. sl@0: * sl@0: * Side effects: sl@0: * If the new value doesn't make sense then this procedure sl@0: * undoes the effect of the variable modification. Otherwise sl@0: * it modifies the format string that's used by Tcl_PrintDouble. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: /* ARGSUSED */ sl@0: char * sl@0: TclPrecTraceProc(clientData, interp, name1, name2, flags) sl@0: ClientData clientData; /* Not used. */ sl@0: Tcl_Interp *interp; /* Interpreter containing variable. */ sl@0: CONST char *name1; /* Name of variable. */ sl@0: CONST char *name2; /* Second part of variable name. */ sl@0: int flags; /* Information about what happened. */ sl@0: { sl@0: CONST char *value; sl@0: char *end; sl@0: int prec; sl@0: sl@0: /* sl@0: * If the variable is unset, then recreate the trace. sl@0: */ sl@0: sl@0: if (flags & TCL_TRACE_UNSETS) { sl@0: if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { sl@0: Tcl_TraceVar2(interp, name1, name2, sl@0: TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES sl@0: |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); sl@0: } sl@0: return (char *) NULL; sl@0: } sl@0: sl@0: /* sl@0: * When the variable is read, reset its value from our shared sl@0: * value. This is needed in case the variable was modified in sl@0: * some other interpreter so that this interpreter's value is sl@0: * out of date. sl@0: */ sl@0: sl@0: Tcl_MutexLock(&precisionMutex); sl@0: sl@0: if (flags & TCL_TRACE_READS) { sl@0: Tcl_SetVar2(interp, name1, name2, precisionString, sl@0: flags & TCL_GLOBAL_ONLY); sl@0: Tcl_MutexUnlock(&precisionMutex); sl@0: return (char *) NULL; sl@0: } sl@0: sl@0: /* sl@0: * The variable is being written. Check the new value and disallow sl@0: * it if it isn't reasonable or if this is a safe interpreter (we sl@0: * don't want safe interpreters messing up the precision of other sl@0: * interpreters). sl@0: */ sl@0: sl@0: if (Tcl_IsSafe(interp)) { sl@0: Tcl_SetVar2(interp, name1, name2, precisionString, sl@0: flags & TCL_GLOBAL_ONLY); sl@0: Tcl_MutexUnlock(&precisionMutex); sl@0: return "can't modify precision from a safe interpreter"; sl@0: } sl@0: value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY); sl@0: if (value == NULL) { sl@0: value = ""; sl@0: } sl@0: prec = strtoul(value, &end, 10); sl@0: if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) || sl@0: (end == value) || (*end != 0)) { sl@0: Tcl_SetVar2(interp, name1, name2, precisionString, sl@0: flags & TCL_GLOBAL_ONLY); sl@0: Tcl_MutexUnlock(&precisionMutex); sl@0: return "improper value for precision"; sl@0: } sl@0: TclFormatInt(precisionString, prec); sl@0: sprintf(precisionFormat, "%%.%dg", prec); sl@0: Tcl_MutexUnlock(&precisionMutex); sl@0: return (char *) NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclNeedSpace -- sl@0: * sl@0: * This procedure checks to see whether it is appropriate to sl@0: * add a space before appending a new list element to an sl@0: * existing string. sl@0: * sl@0: * Results: sl@0: * The return value is 1 if a space is appropriate, 0 otherwise. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclNeedSpace(start, end) sl@0: CONST char *start; /* First character in string. */ sl@0: CONST char *end; /* End of string (place where space will sl@0: * be added, if appropriate). */ sl@0: { sl@0: /* sl@0: * A space is needed unless either sl@0: * (a) we're at the start of the string, or sl@0: */ sl@0: if (end == start) { sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * (b) we're at the start of a nested list-element, quoted with an sl@0: * open curly brace; we can be nested arbitrarily deep, so long sl@0: * as the first curly brace starts an element, so backtrack over sl@0: * open curly braces that are trailing characters of the string; and sl@0: */ sl@0: sl@0: end = Tcl_UtfPrev(end, start); sl@0: while (*end == '{') { sl@0: if (end == start) { sl@0: return 0; sl@0: } sl@0: end = Tcl_UtfPrev(end, start); sl@0: } sl@0: sl@0: /* sl@0: * (c) the trailing character of the string is already a list-element sl@0: * separator (according to TclFindElement); that is, one of these sl@0: * characters: sl@0: * \u0009 \t TAB sl@0: * \u000A \n NEWLINE sl@0: * \u000B \v VERTICAL TAB sl@0: * \u000C \f FORM FEED sl@0: * \u000D \r CARRIAGE RETURN sl@0: * \u0020 SPACE sl@0: * with the condition that the penultimate character is not a sl@0: * backslash. sl@0: */ sl@0: sl@0: if (*end > 0x20) { sl@0: /* sl@0: * Performance tweak. All ASCII spaces are <= 0x20. So get sl@0: * a quick answer for most characters before comparing against sl@0: * all spaces in the switch below. sl@0: * sl@0: * NOTE: Remove this if other Unicode spaces ever get accepted sl@0: * as list-element separators. sl@0: */ sl@0: return 1; sl@0: } sl@0: switch (*end) { sl@0: case ' ': sl@0: case '\t': sl@0: case '\n': sl@0: case '\r': sl@0: case '\v': sl@0: case '\f': sl@0: if ((end == start) || (end[-1] != '\\')) { sl@0: return 0; sl@0: } sl@0: } sl@0: return 1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFormatInt -- sl@0: * sl@0: * This procedure formats an integer into a sequence of decimal digit sl@0: * characters in a buffer. If the integer is negative, a minus sign is sl@0: * inserted at the start of the buffer. A null character is inserted at sl@0: * the end of the formatted characters. It is the caller's sl@0: * responsibility to ensure that enough storage is available. This sl@0: * procedure has the effect of sprintf(buffer, "%d", n) but is faster. sl@0: * sl@0: * Results: sl@0: * An integer representing the number of characters formatted, not sl@0: * including the terminating \0. sl@0: * sl@0: * Side effects: sl@0: * The formatted characters are written into the storage pointer to sl@0: * by the "buffer" argument. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFormatInt(buffer, n) sl@0: char *buffer; /* Points to the storage into which the sl@0: * formatted characters are written. */ sl@0: long n; /* The integer to format. */ sl@0: { sl@0: long intVal; sl@0: int i; sl@0: int numFormatted, j; sl@0: char *digits = "0123456789"; sl@0: sl@0: /* sl@0: * Check first whether "n" is zero. sl@0: */ sl@0: sl@0: if (n == 0) { sl@0: buffer[0] = '0'; sl@0: buffer[1] = 0; sl@0: return 1; sl@0: } sl@0: sl@0: /* sl@0: * Check whether "n" is the maximum negative value. This is sl@0: * -2^(m-1) for an m-bit word, and has no positive equivalent; sl@0: * negating it produces the same value. sl@0: */ sl@0: sl@0: if (n == -n) { sl@0: sprintf(buffer, "%ld", n); sl@0: return strlen(buffer); sl@0: } sl@0: sl@0: /* sl@0: * Generate the characters of the result backwards in the buffer. sl@0: */ sl@0: sl@0: intVal = (n < 0? -n : n); sl@0: i = 0; sl@0: buffer[0] = '\0'; sl@0: do { sl@0: i++; sl@0: buffer[i] = digits[intVal % 10]; sl@0: intVal = intVal/10; sl@0: } while (intVal > 0); sl@0: if (n < 0) { sl@0: i++; sl@0: buffer[i] = '-'; sl@0: } sl@0: numFormatted = i; sl@0: sl@0: /* sl@0: * Now reverse the characters. sl@0: */ sl@0: sl@0: for (j = 0; j < i; j++, i--) { sl@0: char tmp = buffer[i]; sl@0: buffer[i] = buffer[j]; sl@0: buffer[j] = tmp; sl@0: } sl@0: return numFormatted; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLooksLikeInt -- sl@0: * sl@0: * This procedure decides whether the leading characters of a sl@0: * string look like an integer or something else (such as a sl@0: * floating-point number or string). sl@0: * sl@0: * Results: sl@0: * The return value is 1 if the leading characters of p look sl@0: * like a valid Tcl integer. If they look like a floating-point sl@0: * number (e.g. "e01" or "2.4"), or if they don't look like a sl@0: * number at all, then 0 is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclLooksLikeInt(bytes, length) sl@0: register CONST char *bytes; /* Points to first byte of the string. */ sl@0: int length; /* Number of bytes in the string. If < 0 sl@0: * bytes up to the first null byte are sl@0: * considered (if they may appear in an sl@0: * integer). */ sl@0: { sl@0: register CONST char *p; sl@0: sl@0: if ((bytes == NULL) && (length > 0)) { sl@0: Tcl_Panic("TclLooksLikeInt: cannot scan %d bytes from NULL", length); sl@0: } sl@0: sl@0: if (length < 0) { sl@0: length = (bytes? strlen(bytes) : 0); sl@0: } sl@0: sl@0: p = bytes; sl@0: while (length && isspace(UCHAR(*p))) { /* INTL: ISO space. */ sl@0: length--; p++; sl@0: } sl@0: if (length == 0) { sl@0: return 0; sl@0: } sl@0: if ((*p == '+') || (*p == '-')) { sl@0: p++; length--; sl@0: } sl@0: sl@0: return (0 != TclParseInteger(p, length)); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclGetIntForIndex -- sl@0: * sl@0: * This procedure returns an integer corresponding to the list index sl@0: * held in a Tcl object. The Tcl object's value is expected to be sl@0: * either an integer or a string of the form "end([+-]integer)?". sl@0: * sl@0: * Results: sl@0: * The return value is normally TCL_OK, which means that the index was sl@0: * successfully stored into the location referenced by "indexPtr". If sl@0: * the Tcl object referenced by "objPtr" has the value "end", the sl@0: * value stored is "endValue". If "objPtr"s values is not of the form sl@0: * "end([+-]integer)?" and sl@0: * can not be converted to an integer, TCL_ERROR is returned and, if sl@0: * "interp" is non-NULL, an error message is left in the interpreter's sl@0: * result object. sl@0: * sl@0: * Side effects: sl@0: * The object referenced by "objPtr" might be converted to an sl@0: * integer, wide integer, or end-based-index object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclGetIntForIndex(interp, objPtr, endValue, indexPtr) sl@0: Tcl_Interp *interp; /* Interpreter to use for error reporting. sl@0: * If NULL, then no error message is left sl@0: * after errors. */ sl@0: Tcl_Obj *objPtr; /* Points to an object containing either sl@0: * "end" or an integer. */ sl@0: int endValue; /* The value to be stored at "indexPtr" if sl@0: * "objPtr" holds "end". */ sl@0: int *indexPtr; /* Location filled in with an integer sl@0: * representing an index. */ sl@0: { sl@0: if (Tcl_GetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { sl@0: /* sl@0: * If the object is already an offset from the end of the sl@0: * list, or can be converted to one, use it. sl@0: */ sl@0: sl@0: *indexPtr = endValue + objPtr->internalRep.longValue; sl@0: sl@0: } else { sl@0: /* sl@0: * Report a parse error. sl@0: */ sl@0: sl@0: if (interp != NULL) { sl@0: char *bytes = Tcl_GetString(objPtr); sl@0: /* sl@0: * The result might not be empty; this resets it which sl@0: * should be both a cheap operation, and of little problem sl@0: * because this is an error-generation path anyway. sl@0: */ sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad index \"", bytes, sl@0: "\": must be integer or end?-integer?", sl@0: (char *) NULL); sl@0: if (!strncmp(bytes, "end-", 3)) { sl@0: bytes += 3; sl@0: } sl@0: TclCheckBadOctal(interp, bytes); sl@0: } sl@0: sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfEndOffset -- sl@0: * sl@0: * Update the string rep of a Tcl object holding an "end-offset" sl@0: * expression. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Stores a valid string in the object's string rep. sl@0: * sl@0: * This procedure does NOT free any earlier string rep. If it is sl@0: * called on an object that already has a valid string rep, it will sl@0: * leak memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfEndOffset(objPtr) sl@0: register Tcl_Obj* objPtr; sl@0: { sl@0: char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1]; sl@0: register int len; sl@0: sl@0: strcpy(buffer, "end"); sl@0: len = sizeof("end") - 1; sl@0: if (objPtr->internalRep.longValue != 0) { sl@0: buffer[len++] = '-'; sl@0: len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); sl@0: } sl@0: objPtr->bytes = ckalloc((unsigned) (len+1)); sl@0: strcpy(objPtr->bytes, buffer); sl@0: objPtr->length = len; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * SetEndOffsetFromAny -- sl@0: * sl@0: * Look for a string of the form "end-offset" and convert it sl@0: * to an internal representation holding the offset. sl@0: * sl@0: * Results: sl@0: * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. sl@0: * sl@0: * Side effects: sl@0: * If interp is not NULL, stores an error message in the sl@0: * interpreter result. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetEndOffsetFromAny(interp, objPtr) sl@0: Tcl_Interp* interp; /* Tcl interpreter or NULL */ sl@0: Tcl_Obj* objPtr; /* Pointer to the object to parse */ sl@0: { sl@0: int offset; /* Offset in the "end-offset" expression */ sl@0: Tcl_ObjType* oldTypePtr = objPtr->typePtr; sl@0: /* Old internal rep type of the object */ sl@0: register char* bytes; /* String rep of the object */ sl@0: int length; /* Length of the object's string rep */ sl@0: sl@0: /* If it's already the right type, we're fine. */ sl@0: sl@0: if (objPtr->typePtr == &tclEndOffsetType) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* Check for a string rep of the right form. */ sl@0: sl@0: bytes = Tcl_GetStringFromObj(objPtr, &length); sl@0: if ((*bytes != 'e') || (strncmp(bytes, "end", sl@0: (size_t)((length > 3) ? 3 : length)) != 0)) { sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad index \"", bytes, sl@0: "\": must be end?-integer?", sl@0: (char*) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* Convert the string rep */ sl@0: sl@0: if (length <= 3) { sl@0: offset = 0; sl@0: } else if ((length > 4) && (bytes[3] == '-')) { sl@0: /* sl@0: * This is our limited string expression evaluator. Pass everything sl@0: * after "end-" to Tcl_GetInt, then reverse for offset. sl@0: */ sl@0: if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: offset = -offset; sl@0: } else { sl@0: /* sl@0: * Conversion failed. Report the error. sl@0: */ sl@0: if (interp != NULL) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "bad index \"", bytes, sl@0: "\": must be integer or end?-integer?", sl@0: (char *) NULL); sl@0: } sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * The conversion succeeded. Free the old internal rep and set sl@0: * the new one. sl@0: */ sl@0: sl@0: if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { sl@0: oldTypePtr->freeIntRepProc(objPtr); sl@0: } sl@0: sl@0: objPtr->internalRep.longValue = offset; sl@0: objPtr->typePtr = &tclEndOffsetType; sl@0: sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCheckBadOctal -- sl@0: * sl@0: * This procedure checks for a bad octal value and appends a sl@0: * meaningful error to the interp's result. sl@0: * sl@0: * Results: sl@0: * 1 if the argument was a bad octal, else 0. sl@0: * sl@0: * Side effects: sl@0: * The interpreter's result is modified. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclCheckBadOctal(interp, value) sl@0: Tcl_Interp *interp; /* Interpreter to use for error reporting. sl@0: * If NULL, then no error message is left sl@0: * after errors. */ sl@0: CONST char *value; /* String to check. */ sl@0: { sl@0: register CONST char *p = value; sl@0: sl@0: /* sl@0: * A frequent mistake is invalid octal values due to an unwanted sl@0: * leading zero. Try to generate a meaningful error message. sl@0: */ sl@0: sl@0: while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ sl@0: p++; sl@0: } sl@0: if (*p == '+' || *p == '-') { sl@0: p++; sl@0: } sl@0: if (*p == '0') { sl@0: while (isdigit(UCHAR(*p))) { /* INTL: digit. */ sl@0: p++; sl@0: } sl@0: while (isspace(UCHAR(*p))) { /* INTL: ISO space. */ sl@0: p++; sl@0: } sl@0: if (*p == '\0') { sl@0: /* Reached end of string */ sl@0: if (interp != NULL) { sl@0: /* sl@0: * Don't reset the result here because we want this result sl@0: * to be added to an existing error message as extra info. sl@0: */ sl@0: Tcl_AppendResult(interp, " (looks like invalid octal number)", sl@0: (char *) NULL); sl@0: } sl@0: return 1; sl@0: } sl@0: } sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetNameOfExecutable -- sl@0: * sl@0: * This procedure simply returns a pointer to the internal full sl@0: * path name of the executable file as computed by sl@0: * Tcl_FindExecutable. This procedure call is the C API sl@0: * equivalent to the "info nameofexecutable" command. sl@0: * sl@0: * Results: sl@0: * A pointer to the internal string or NULL if the internal full sl@0: * path name has not been computed or unknown. sl@0: * sl@0: * Side effects: sl@0: * The object referenced by "objPtr" might be converted to an sl@0: * integer object. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C CONST char * sl@0: Tcl_GetNameOfExecutable() sl@0: { sl@0: return tclExecutableName; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclpGetTime -- sl@0: * sl@0: * Deprecated synonym for Tcl_GetTime. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Stores current time in the buffer designated by "timePtr" sl@0: * sl@0: * This procedure is provided for the benefit of extensions written sl@0: * before Tcl_GetTime was exported from the library. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclpGetTime(timePtr) sl@0: Tcl_Time* timePtr; sl@0: { sl@0: Tcl_GetTime(timePtr); sl@0: }