From c4d42a0b51819cf2b64177e9979a3085d0de613e Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 17 Jul 2005 21:17:30 +0000 Subject: Getting more systematic about style --- generic/tclBinary.c | 1676 +++++++++++++------------ generic/tclCmdAH.c | 1541 +++++++++++------------ generic/tclCmdIL.c | 1138 ++++++++--------- generic/tclCmdMZ.c | 2850 ++++++++++++++++++++++--------------------- generic/tclCompExpr.c | 538 ++++----- generic/tclEncoding.c | 967 ++++++++------- generic/tclEvent.c | 439 +++---- generic/tclFileName.c | 962 ++++++++------- generic/tclIO.c | 3183 ++++++++++++++++++++++++------------------------ generic/tclIOCmd.c | 782 ++++++------ generic/tclIOGT.c | 1153 +++++++++--------- generic/tclIOUtil.c | 3224 +++++++++++++++++++++++++------------------------ generic/tclInterp.c | 2022 +++++++++++++++---------------- generic/tclLink.c | 146 +-- generic/tclLoad.c | 439 +++---- generic/tclNamesp.c | 448 +++---- generic/tclObj.c | 1380 ++++++++++----------- 17 files changed, 11637 insertions(+), 11251 deletions(-) diff --git a/generic/tclBinary.c b/generic/tclBinary.c index bb370e0..c6231f0 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -1,4 +1,4 @@ -/* +/* * tclBinary.c -- * * This file contains the implementation of the "binary" Tcl built-in @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBinary.c,v 1.24 2005/05/13 17:11:59 dgp Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.25 2005/07/17 21:17:30 dkf Exp $ */ #include "tclInt.h" @@ -26,21 +26,20 @@ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* - * The following defines the maximum number of different (integer) - * numbers placed in the object cache by 'binary scan' before it bails - * out and switches back to Plan A (creating a new object for each - * value.) Theoretically, it would be possible to keep the cache - * about for the values that are already in it, but that makes the - * code slower in practise when overflow happens, and makes little - * odds the rest of the time (as measured on my machine.) It is also - * slower (on the sample I tried at least) to grow the cache to hold - * all items we might want to put in it; presumably the extra cost of - * managing the memory for the enlarged table outweighs the benefit - * from allocating fewer objects. This is probably because as the - * number of objects increases, the likelihood of reuse of any - * particular one drops, and there is very little gain from larger - * maximum cache sizes (the value below is chosen to allow caching to - * work in full with conversion of bytes.) - DKF + * The following defines the maximum number of different (integer) numbers + * placed in the object cache by 'binary scan' before it bails out and + * switches back to Plan A (creating a new object for each value.) + * Theoretically, it would be possible to keep the cache about for the values + * that are already in it, but that makes the code slower in practise when + * overflow happens, and makes little odds the rest of the time (as measured + * on my machine.) It is also slower (on the sample I tried at least) to grow + * the cache to hold all items we might want to put in it; presumably the + * extra cost of managing the memory for the enlarged table outweighs the + * benefit from allocating fewer objects. This is probably because as the + * number of objects increases, the likelihood of reuse of any particular one + * drops, and there is very little gain from larger maximum cache sizes (the + * value below is chosen to allow caching to work in full with conversion of + * bytes.) - DKF */ #define BINARY_SCAN_MAX_CACHE 260 @@ -68,28 +67,28 @@ static void CopyNumber _ANSI_ARGS_((CONST void *from, void *to, unsigned int length, int type)); /* - * The following object type represents an array of bytes. An array of - * bytes is not equivalent to an internationalized string. Conceptually, a - * string is an array of 16-bit quantities organized as a sequence of properly - * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. + * The following object type represents an array of bytes. An array of bytes + * is not equivalent to an internationalized string. Conceptually, a string + * is an array of 16-bit quantities organized as a sequence of properly formed + * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. * Accessor functions are provided to convert a ByteArray to a String or a * String to a ByteArray. Two or more consecutive bytes in an array of bytes * may look like a single UTF-8 character if the array is casually treated as * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one - * map between bytes and characters. + * produced properly formed UTF-8 sequences so that there is a one-to-one map + * between bytes and characters. * * Converting a ByteArray to a String proceeds by casting each byte in the * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. - * For ByteArrays consisting entirely of values 1..127, the corresponding - * String representation is the same as the ByteArray representation. + * and storing the UTF-8 version of that Unicode character in the String. For + * ByteArrays consisting entirely of values 1..127, the corresponding String + * representation is the same as the ByteArray representation. * * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a - * byte by truncating the upper 8 bits, and then storing the byte in the - * ByteArray. Converting from ByteArray to String and back to ByteArray - * is not lossy, but converting an arbitrary String to a ByteArray may be. + * representation of each character in the String, casting it to a byte by + * truncating the upper 8 bits, and then storing the byte in the ByteArray. + * Converting from ByteArray to String and back to ByteArray is not lossy, but + * converting an arbitrary String to a ByteArray may be. */ Tcl_ObjType tclByteArrayType = { @@ -101,10 +100,10 @@ Tcl_ObjType tclByteArrayType = { }; /* - * The following structure is the internal rep for a ByteArray object. - * Keeps track of how much memory has been used and how much has been - * allocated for the byte array to enable growing and shrinking of the - * ByteArray object with fewer mallocs. + * The following structure is the internal rep for a ByteArray object. Keeps + * track of how much memory has been used and how much has been allocated for + * the byte array to enable growing and shrinking of the ByteArray object with + * fewer mallocs. */ typedef struct ByteArray { @@ -130,13 +129,12 @@ typedef struct ByteArray { * * Tcl_NewByteArrayObj -- * - * This procedure is creates a new ByteArray object and initializes - * it from the given array of bytes. + * This procedure is creates a new ByteArray object and initializes it + * from the given array of bytes. * * Results: - * The newly create object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly create object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. @@ -147,13 +145,12 @@ typedef struct ByteArray { #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj - Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + CONST unsigned char *bytes; /* The array of bytes used to initialize the + * new object. */ + int length; /* Length of the array of bytes, which must be + * >= 0. */ { return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); } @@ -162,10 +159,10 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + CONST unsigned char *bytes; /* The array of bytes used to initialize the + * new object. */ + int length; /* Length of the array of bytes, which must be + * >= 0. */ { Tcl_Obj *objPtr; @@ -191,9 +188,8 @@ Tcl_NewByteArrayObj(bytes, length) * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly create object is returned. This object will have no - * initial string representation. The returned object has a ref count - * of 0. + * The newly create object is returned. This object will have no initial + * string representation. The returned object has a ref count of 0. * * Side effects: * Memory allocated for new object and copy of byte array argument. @@ -205,14 +201,14 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + CONST unsigned char *bytes; /* The array of bytes used to initialize the + * new object. */ + int length; /* Length of the array of bytes, which must be + * >= 0. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { Tcl_Obj *objPtr; @@ -225,14 +221,14 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - CONST unsigned char *bytes; /* The array of bytes used to initialize - * the new object. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + CONST unsigned char *bytes; /* The array of bytes used to initialize the + * new object. */ + int length; /* Length of the array of bytes, which must be + * >= 0. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewByteArrayObj(bytes, length); } @@ -250,8 +246,8 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) * None. * * Side effects: - * The object's old string rep and internal rep is freed. - * Memory allocated for copy of byte array argument. + * The object's old string rep and internal rep is freed. Memory + * allocated for copy of byte array argument. * *---------------------------------------------------------------------- */ @@ -261,8 +257,8 @@ Tcl_SetByteArrayObj(objPtr, bytes, length) Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ CONST unsigned char *bytes; /* The array of bytes to use as the new * value. */ - int length; /* Length of the array of bytes, which must - * be >= 0. */ + int length; /* Length of the array of bytes, which must be + * >= 0. */ { ByteArray *byteArrayPtr; @@ -286,9 +282,9 @@ Tcl_SetByteArrayObj(objPtr, bytes, length) * * Tcl_GetByteArrayFromObj -- * - * Attempt to get the array of bytes from the Tcl object. If the - * object is not already a ByteArray object, an attempt will be - * made to convert it to one. + * Attempt to get the array of bytes from the Tcl object. If the object + * is not already a ByteArray object, an attempt will be made to convert + * it to one. * * Results: * Pointer to array of bytes representing the ByteArray object. @@ -306,7 +302,7 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr) * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - + SetByteArrayFromAny(NULL, objPtr); baPtr = GET_BYTEARRAY(objPtr); @@ -321,19 +317,19 @@ Tcl_GetByteArrayFromObj(objPtr, lengthPtr) * * Tcl_SetByteArrayLength -- * - * This procedure changes the length of the byte array for this - * object. Once the caller has set the length of the array, it - * is acceptable to directly modify the bytes in the array up until - * Tcl_GetStringFromObj() has been called on this object. + * This procedure changes the length of the byte array for this object. + * Once the caller has set the length of the array, it is acceptable to + * directly modify the bytes in the array up until Tcl_GetStringFromObj() + * has been called on this object. * * Results: * The new byte array of the specified length. * * Side effects: - * Allocates enough memory for an array of bytes of the requested - * size. When growing the array, the old array is copied to the - * new array; new bytes are undefined. When shrinking, the - * old array is truncated to the specified length. + * Allocates enough memory for an array of bytes of the requested size. + * When growing the array, the old array is copied to the new array; new + * bytes are undefined. When shrinking, the old array is truncated to the + * specified length. * *---------------------------------------------------------------------- */ @@ -344,7 +340,7 @@ Tcl_SetByteArrayLength(objPtr, length) int length; /* New length for internal byte array. */ { ByteArray *byteArrayPtr, *newByteArrayPtr; - + if (Tcl_IsShared(objPtr)) { Tcl_Panic("Tcl_SetObjLength called with shared object"); } @@ -394,7 +390,7 @@ SetByteArrayFromAny(interp, objPtr) unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; - + if (objPtr->typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); srcEnd = src + length; @@ -427,7 +423,7 @@ SetByteArrayFromAny(interp, objPtr) * None. * * Side effects: - * Frees memory. + * Frees memory. * *---------------------------------------------------------------------- */ @@ -444,9 +440,8 @@ FreeByteArrayInternalRep(objPtr) * * DupByteArrayInternalRep -- * - * Initialize the internal representation of a ByteArray Tcl_Obj - * to a copy of the internal representation of an existing ByteArray - * object. + * Initialize the internal representation of a ByteArray Tcl_Obj to a + * copy of the internal representation of an existing ByteArray object. * * Results: * None. @@ -463,7 +458,7 @@ DupByteArrayInternalRep(srcPtr, copyPtr) Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { int length; - ByteArray *srcArrayPtr, *copyArrayPtr; + ByteArray *srcArrayPtr, *copyArrayPtr; srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; @@ -483,19 +478,19 @@ DupByteArrayInternalRep(srcPtr, copyPtr) * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. - * Note: This procedure does not invalidate an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. Note: + * This procedure does not invalidate an existing old string rep so + * storage will be lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the ByteArray-to-string conversion. + * The object's string is set to a valid string that results from the + * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is - * discarded and the typePtr becomes NULL. + * The object becomes a string object -- the internal rep is discarded + * and the typePtr becomes NULL. * *---------------------------------------------------------------------- */ @@ -517,7 +512,7 @@ UpdateStringOfByteArray(objPtr) /* * How much space will string rep need? */ - + size = length; for (i = 0; i < length; i++) { if ((src[i] == 0) || (src[i] > 127)) { @@ -578,10 +573,10 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) * cursor has visited.*/ char *errorString, *errorValue, *str; int offset, size, length, index; - static CONST char *options[] = { - "format", "scan", NULL + static CONST char *options[] = { + "format", "scan", NULL }; - enum options { + enum options { BINARY_FORMAT, BINARY_SCAN }; @@ -596,771 +591,753 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } switch ((enum options) index) { - case BINARY_FORMAT: { - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); - return TCL_ERROR; + case BINARY_FORMAT: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); + return TCL_ERROR; + } + + /* + * To avoid copying the data, we format the string in two passes. The + * first pass computes the size of the output buffer. The second pass + * places the formatted data into the buffer. + */ + + format = Tcl_GetString(objv[2]); + arg = 3; + offset = 0; + length = 0; + while (*format != '\0') { + str = format; + if (!GetFormatSpec(&format, &cmd, &count)) { + break; } + switch (cmd) { + case 'a': + case 'A': + case 'b': + case 'B': + case 'h': + case 'H': + /* + * For string-type specifiers, the count corresponds to the + * number of bytes in a single argument. + */ - /* - * To avoid copying the data, we format the string in two passes. - * The first pass computes the size of the output buffer. The - * second pass places the formatted data into the buffer. - */ - - format = Tcl_GetString(objv[2]); - arg = 3; - offset = 0; - length = 0; - while (*format != '\0') { - str = format; - if (!GetFormatSpec(&format, &cmd, &count)) { - break; + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + arg++; + if (cmd == 'a' || cmd == 'A') { + offset += count; + } else if (cmd == 'b' || cmd == 'B') { + offset += (count + 7) / 8; + } else { + offset += (count + 1) / 2; + } + break; + case 'c': + size = 1; + goto doNumbers; + case 't': + case 's': + case 'S': + size = 2; + goto doNumbers; + case 'n': + case 'i': + case 'I': + size = 4; + goto doNumbers; + case 'm': + case 'w': + case 'W': + size = 8; + goto doNumbers; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto doNumbers; + case 'q': + case 'Q': + case 'd': + size = sizeof(double); + + doNumbers: + if (arg >= objc) { + goto badIndex; } - switch (cmd) { - case 'a': - case 'A': - case 'b': - case 'B': - case 'h': - case 'H': { - /* - * For string-type specifiers, the count corresponds - * to the number of bytes in a single argument. - */ - - if (arg >= objc) { - goto badIndex; - } - if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - arg++; - if (cmd == 'a' || cmd == 'A') { - offset += count; - } else if (cmd == 'b' || cmd == 'B') { - offset += (count + 7) / 8; - } else { - offset += (count + 1) / 2; - } - break; - } - case 'c': { - size = 1; - goto doNumbers; - } - case 't': - case 's': - case 'S': { - size = 2; - goto doNumbers; - } - case 'n': - case 'i': - case 'I': { - size = 4; - goto doNumbers; - } - case 'm': - case 'w': - case 'W': { - size = 8; - goto doNumbers; - } - case 'r': - case 'R': - case 'f': { - size = sizeof(float); - goto doNumbers; - } - case 'q': - case 'Q': - case 'd': { - size = sizeof(double); - - doNumbers: - if (arg >= objc) { - goto badIndex; - } - /* - * For number-type specifiers, the count corresponds - * to the number of elements in the list stored in - * a single argument. If no count is specified, then - * the argument is taken as a single non-list value. - */ + /* + * For number-type specifiers, the count corresponds to the + * number of elements in the list stored in a single argument. + * If no count is specified, then the argument is taken as a + * single non-list value. + */ - if (count == BINARY_NOCOUNT) { - arg++; - count = 1; - } else { - int listc; - Tcl_Obj **listv; - if (Tcl_ListObjGetElements(interp, objv[arg++], - &listc, &listv) != TCL_OK) { - return TCL_ERROR; - } - if (count == BINARY_ALL) { - count = listc; - } else if (count > listc) { - Tcl_AppendResult(interp, - "number of elements in list does not match count", - (char *) NULL); - return TCL_ERROR; - } - } - offset += count*size; - break; - } - case 'x': { - if (count == BINARY_ALL) { - Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - (char *) NULL); - return TCL_ERROR; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - offset += count; - break; - } - case 'X': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count > offset) || (count == BINARY_ALL)) { - count = offset; - } - if (offset > length) { - length = offset; - } - offset -= count; - break; - } - case '@': { - if (offset > length) { - length = offset; - } - if (count == BINARY_ALL) { - offset = length; - } else if (count == BINARY_NOCOUNT) { - goto badCount; - } else { - offset = count; - } - break; + if (count == BINARY_NOCOUNT) { + arg++; + count = 1; + } else { + int listc; + Tcl_Obj **listv; + + if (Tcl_ListObjGetElements(interp, objv[arg++], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; } - default: { - errorString = str; - goto badField; + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + Tcl_AppendResult(interp, + "number of elements in list does not match count", + (char *) NULL); + return TCL_ERROR; } } + offset += count*size; + break; + + case 'x': + if (count == BINARY_ALL) { + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + (char *) NULL); + return TCL_ERROR; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + offset += count; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count > offset) || (count == BINARY_ALL)) { + count = offset; + } + if (offset > length) { + length = offset; + } + offset -= count; + break; + case '@': + if (offset > length) { + length = offset; + } + if (count == BINARY_ALL) { + offset = length; + } else if (count == BINARY_NOCOUNT) { + goto badCount; + } else { + offset = count; + } + break; + default: + errorString = str; + goto badField; + } + } + if (offset > length) { + length = offset; + } + if (length == 0) { + return TCL_OK; + } + + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. + */ + + resultPtr = Tcl_NewObj(); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset((VOID *) buffer, 0, (size_t) length); + + /* + * Pack the data into the result object. Note that we can skip the + * error checking during this pass, since we have already parsed the + * string once. + */ + + arg = 3; + format = Tcl_GetString(objv[2]); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + if (!GetFormatSpec(&format, &cmd, &count)) { + break; } - if (offset > length) { - length = offset; + if ((count == 0) && (cmd != '@')) { + arg++; + continue; } - if (length == 0) { - return TCL_OK; + switch (cmd) { + case 'a': + case 'A': { + char pad = (char) (cmd == 'a' ? '\0' : ' '); + unsigned char *bytes; + + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + if (length >= count) { + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) count); + } else { + memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); + memset((VOID *) (cursor + length), pad, + (size_t) (count - length)); + } + cursor += count; + break; } - - /* - * Prepare the result object by preallocating the caclulated - * number of bytes and filling with nulls. - */ - - resultPtr = Tcl_NewObj(); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset((VOID *) buffer, 0, (size_t) length); - - /* - * Pack the data into the result object. Note that we can skip - * the error checking during this pass, since we have already - * parsed the string once. - */ - - arg = 3; - format = Tcl_GetString(objv[2]); - cursor = buffer; - maxPos = cursor; - while (*format != 0) { - if (!GetFormatSpec(&format, &cmd, &count)) { - break; + case 'b': + case 'B': { + unsigned char *last; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; } - if ((count == 0) && (cmd != '@')) { - arg++; - continue; + last = cursor + ((count + 7) / 8); + if (count > length) { + count = length; } - switch (cmd) { - case 'a': - case 'A': { - char pad = (char) (cmd == 'a' ? '\0' : ' '); - unsigned char *bytes; - - bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); - - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; + value = 0; + errorString = "binary"; + if (cmd == 'B') { + for (offset = 0; offset < count; offset++) { + value <<= 1; + if (str[offset] == '1') { + value |= 1; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; } - if (length >= count) { - memcpy((VOID *) cursor, (VOID *) bytes, - (size_t) count); - } else { - memcpy((VOID *) cursor, (VOID *) bytes, - (size_t) length); - memset((VOID *) (cursor + length), pad, - (size_t) (count - length)); + if (((offset + 1) % 8) == 0) { + *cursor++ = (unsigned char) value; + value = 0; } - cursor += count; - break; } - case 'b': - case 'B': { - unsigned char *last; - - str = Tcl_GetStringFromObj(objv[arg++], &length); - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 7) / 8); - if (count > length) { - count = length; + } else { + for (offset = 0; offset < count; offset++) { + value >>= 1; + if (str[offset] == '1') { + value |= 128; + } else if (str[offset] != '0') { + errorValue = str; + goto badValue; } - value = 0; - errorString = "binary"; - if (cmd == 'B') { - for (offset = 0; offset < count; offset++) { - value <<= 1; - if (str[offset] == '1') { - value |= 1; - } else if (str[offset] != '0') { - errorValue = str; - goto badValue; - } - if (((offset + 1) % 8) == 0) { - *cursor++ = (unsigned char) value; - value = 0; - } - } - } else { - for (offset = 0; offset < count; offset++) { - value >>= 1; - if (str[offset] == '1') { - value |= 128; - } else if (str[offset] != '0') { - errorValue = str; - goto badValue; - } - if (!((offset + 1) % 8)) { - *cursor++ = (unsigned char) value; - value = 0; - } - } - } - if ((offset % 8) != 0) { - if (cmd == 'B') { - value <<= 8 - (offset % 8); - } else { - value >>= 8 - (offset % 8); - } + if (!((offset + 1) % 8)) { *cursor++ = (unsigned char) value; + value = 0; } - while (cursor < last) { - *cursor++ = '\0'; - } - break; } - case 'h': - case 'H': { - unsigned char *last; - int c; - - str = Tcl_GetStringFromObj(objv[arg++], &length); - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; + } + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); + } + *cursor++ = (unsigned char) value; + } + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'h': + case 'H': { + unsigned char *last; + int c; + + str = Tcl_GetStringFromObj(objv[arg++], &length); + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 1) / 2); + if (count > length) { + count = length; + } + value = 0; + errorString = "hexadecimal"; + if (cmd == 'H') { + for (offset = 0; offset < count; offset++) { + value <<= 4; + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ + errorValue = str; + goto badValue; } - last = cursor + ((count + 1) / 2); - if (count > length) { - count = length; + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; } - value = 0; - errorString = "hexadecimal"; - if (cmd == 'H') { - for (offset = 0; offset < count; offset++) { - value <<= 4; - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); - } - value |= (c & 0xf); - if (offset % 2) { - *cursor++ = (char) value; - value = 0; - } - } - } else { - for (offset = 0; offset < count; offset++) { - value >>= 4; - - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); - } - value |= ((c << 4) & 0xf0); - if (offset % 2) { - *cursor++ = (unsigned char)(value & 0xff); - value = 0; - } - } + if (c > 16) { + c += ('A' - 'a'); } + value |= (c & 0xf); if (offset % 2) { - if (cmd == 'H') { - value <<= 4; - } else { - value >>= 4; - } - *cursor++ = (unsigned char) value; + *cursor++ = (char) value; + value = 0; } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 4; - while (cursor < last) { - *cursor++ = '\0'; + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ + errorValue = str; + goto badValue; } - break; - } - case 'c': - case 't': - case 's': - case 'S': - case 'n': - case 'i': - case 'I': - case 'm': - case 'w': - case 'W': - case 'r': - case 'R': - case 'd': - case 'q': - case 'Q': - case 'f': { - int listc, i; - Tcl_Obj **listv; - - if (count == BINARY_NOCOUNT) { - /* - * Note that we are casting away the const-ness of - * objv, but this is safe since we aren't going to - * modify the array. - */ - - listv = (Tcl_Obj**)(objv + arg); - listc = 1; - count = 1; - } else { - Tcl_ListObjGetElements(interp, objv[arg], - &listc, &listv); - if (count == BINARY_ALL) { - count = listc; - } + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; } - arg++; - for (i = 0; i < count; i++) { - if (FormatNumber(interp, cmd, listv[i], &cursor) - != TCL_OK) { - return TCL_ERROR; - } + if (c > 16) { + c += ('A' - 'a'); } - break; - } - case 'x': { - if (count == BINARY_NOCOUNT) { - count = 1; + value |= ((c << 4) & 0xf0); + if (offset % 2) { + *cursor++ = (unsigned char)(value & 0xff); + value = 0; } - memset(cursor, 0, (size_t) count); - cursor += count; - break; } - case 'X': { - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) - || (count > (cursor - buffer))) { - cursor = buffer; - } else { - cursor -= count; - } - break; + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; } - case '@': { - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_ALL) { - cursor = maxPos; - } else { - cursor = buffer + count; - } - break; + *cursor++ = (unsigned char) value; + } + + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'c': + case 't': + case 's': + case 'S': + case 'n': + case 'i': + case 'I': + case 'm': + case 'w': + case 'W': + case 'r': + case 'R': + case 'd': + case 'q': + case 'Q': + case 'f': { + int listc, i; + Tcl_Obj **listv; + + if (count == BINARY_NOCOUNT) { + /* + * Note that we are casting away the const-ness of objv, + * but this is safe since we aren't going to modify the + * array. + */ + + listv = (Tcl_Obj**)(objv + arg); + listc = 1; + count = 1; + } else { + Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); + if (count == BINARY_ALL) { + count = listc; + } + } + arg++; + for (i = 0; i < count; i++) { + if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { + return TCL_ERROR; } } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + memset(cursor, 0, (size_t) count); + cursor += count; + break; + case 'X': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > (cursor - buffer))) { + cursor = buffer; + } else { + cursor -= count; + } + break; + case '@': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; + } + break; } - Tcl_SetObjResult(interp, resultPtr); - break; } - case BINARY_SCAN: { - int i; - Tcl_Obj *valuePtr, *elementPtr; - Tcl_HashTable numberCacheHash; - Tcl_HashTable *numberCachePtr; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "value formatString ?varName varName ...?"); - return TCL_ERROR; + Tcl_SetObjResult(interp, resultPtr); + break; + case BINARY_SCAN: { + int i; + Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, + "value formatString ?varName varName ...?"); + return TCL_ERROR; + } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[2], &length); + format = Tcl_GetString(objv[3]); + cursor = buffer; + arg = 4; + offset = 0; + while (*format != '\0') { + str = format; + if (!GetFormatSpec(&format, &cmd, &count)) { + goto done; } - numberCachePtr = &numberCacheHash; - Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[2], &length); - format = Tcl_GetString(objv[3]); - cursor = buffer; - arg = 4; - offset = 0; - while (*format != '\0') { - str = format; - if (!GetFormatSpec(&format, &cmd, &count)) { - goto done; + switch (cmd) { + case 'a': + case 'A': { + unsigned char *src; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = length - offset; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)) { + goto done; + } } - switch (cmd) { - case 'a': - case 'A': { - unsigned char *src; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = length - offset; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)) { - goto done; - } - } - src = buffer + offset; - size = count; + src = buffer + offset; + size = count; - /* - * Trim trailing nulls and spaces, if necessary. - */ + /* + * Trim trailing nulls and spaces, if necessary. + */ - if (cmd == 'A') { - while (size > 0) { - if (src[size-1] != '\0' && src[size-1] != ' ') { - break; - } - size--; - } - } - valuePtr = Tcl_NewByteArrayObj(src, size); - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; + if (cmd == 'A') { + while (size > 0) { + if (src[size-1] != '\0' && src[size-1] != ' ') { + break; } - offset += count; - break; + size--; } - case 'b': - case 'B': { - unsigned char *src; - char *dest; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset) * 8; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset) * 8) { - goto done; - } - } - src = buffer + offset; - valuePtr = Tcl_NewObj(); - Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetString(valuePtr); - - if (cmd == 'b') { - for (i = 0; i < count; i++) { - if (i % 8) { - value >>= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 1) ? '1' : '0'); - } - } else { - for (i = 0; i < count; i++) { - if (i % 8) { - value <<= 1; - } else { - value = *src++; - } - *dest++ = (char) ((value & 0x80) ? '1' : '0'); - } - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - offset += (count + 7 ) / 8; - break; + } + + /* + * Have to do this #ifdef-fery because (as part of defining + * Tcl_NewByteArrayObj) we removed the #def that hides this + * stuff normally. If this code ever gets copied to another + * file, it should be changed back to the simpler version. + */ + +#ifdef TCL_MEM_DEBUG + valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__); +#else + valuePtr = Tcl_NewByteArrayObj(src, size); +#endif /* TCL_MEM_DEBUG */ + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += count; + break; + } + case 'b': + case 'B': { + unsigned char *src; + char *dest; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset) * 8; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; } - case 'h': - case 'H': { - char *dest; - unsigned char *src; - int i; - static char hexdigit[] = "0123456789abcdef"; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = (length - offset)*2; + if (count > (length - offset) * 8) { + goto done; + } + } + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetString(valuePtr); + + if (cmd == 'b') { + for (i = 0; i < count; i++) { + if (i % 8) { + value >>= 1; } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)*2) { - goto done; - } + value = *src++; } - src = buffer + offset; - valuePtr = Tcl_NewObj(); - Tcl_SetObjLength(valuePtr, count); - dest = Tcl_GetString(valuePtr); - - if (cmd == 'h') { - for (i = 0; i < count; i++) { - if (i % 2) { - value >>= 4; - } else { - value = *src++; - } - *dest++ = hexdigit[value & 0xf]; - } + *dest++ = (char) ((value & 1) ? '1' : '0'); + } + } else { + for (i = 0; i < count; i++) { + if (i % 8) { + value <<= 1; } else { - for (i = 0; i < count; i++) { - if (i % 2) { - value <<= 4; - } else { - value = *src++; - } - *dest++ = hexdigit[(value >> 4) & 0xf]; - } + value = *src++; } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; - } - offset += (count + 1) / 2; - break; - } - case 'c': { - size = 1; - goto scanNumber; - } - case 't': - case 's': - case 'S': { - size = 2; - goto scanNumber; + *dest++ = (char) ((value & 0x80) ? '1' : '0'); } - case 'n': - case 'i': - case 'I': { - size = 4; - goto scanNumber; - } - case 'm': - case 'w': - case 'W': { - size = 8; - goto scanNumber; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 7 ) / 8; + break; + } + case 'h': + case 'H': { + char *dest; + unsigned char *src; + int i; + static char hexdigit[] = "0123456789abcdef"; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*2; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; } - case 'r': - case 'R': - case 'f': { - size = sizeof(float); - goto scanNumber; + if (count > (length - offset)*2) { + goto done; } - case 'q': - case 'Q': - case 'd': { - unsigned char *src; - - size = sizeof(double); - /* fall through */ - - scanNumber: - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_NOCOUNT) { - if ((length - offset) < size) { - goto done; - } - valuePtr = ScanNumber(buffer+offset, cmd, - &numberCachePtr); - offset += size; + } + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = Tcl_GetString(valuePtr); + + if (cmd == 'h') { + for (i = 0; i < count; i++) { + if (i % 2) { + value >>= 4; } else { - if (count == BINARY_ALL) { - count = (length - offset) / size; - } - if ((length - offset) < (count * size)) { - goto done; - } - valuePtr = Tcl_NewObj(); - src = buffer+offset; - for (i = 0; i < count; i++) { - elementPtr = ScanNumber(src, cmd, - &numberCachePtr); - src += size; - Tcl_ListObjAppendElement(NULL, valuePtr, - elementPtr); - } - offset += count*size; - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], - NULL, valuePtr, TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - Tcl_DecrRefCount(valuePtr); /* unneeded */ - return TCL_ERROR; + value = *src++; } - break; + *dest++ = hexdigit[value & 0xf]; } - case 'x': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) - || (count > (length - offset))) { - offset = length; + } else { + for (i = 0; i < count; i++) { + if (i % 2) { + value <<= 4; } else { - offset += count; + value = *src++; } - break; + *dest++ = hexdigit[(value >> 4) & 0xf]; } - case 'X': { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > offset)) { - offset = 0; - } else { - offset -= count; - } - break; + } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + offset += (count + 1) / 2; + break; + } + case 'c': + size = 1; + goto scanNumber; + case 't': + case 's': + case 'S': + size = 2; + goto scanNumber; + case 'n': + case 'i': + case 'I': + size = 4; + goto scanNumber; + case 'm': + case 'w': + case 'W': + size = 8; + goto scanNumber; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + goto scanNumber; + case 'q': + case 'Q': + case 'd': { + unsigned char *src; + + size = sizeof(double); + /* fall through */ + + scanNumber: + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_NOCOUNT) { + if ((length - offset) < size) { + goto done; } - case '@': { - if (count == BINARY_NOCOUNT) { - DeleteScanNumberCache(numberCachePtr); - goto badCount; - } - if ((count == BINARY_ALL) || (count > length)) { - offset = length; - } else { - offset = count; - } - break; + valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr); + offset += size; + } else { + if (count == BINARY_ALL) { + count = (length - offset) / size; + } + if ((length - offset) < (count * size)) { + goto done; } - default: { - DeleteScanNumberCache(numberCachePtr); - errorString = str; - goto badField; + valuePtr = Tcl_NewObj(); + src = buffer+offset; + for (i = 0; i < count; i++) { + elementPtr = ScanNumber(src, cmd, &numberCachePtr); + src += size; + Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); } + offset += count*size; } + + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + Tcl_DecrRefCount(valuePtr); /* unneeded */ + return TCL_ERROR; + } + break; + } + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > (length - offset))) { + offset = length; + } else { + offset += count; + } + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > offset)) { + offset = 0; + } else { + offset -= count; + } + break; + case '@': + if (count == BINARY_NOCOUNT) { + DeleteScanNumberCache(numberCachePtr); + goto badCount; + } + if ((count == BINARY_ALL) || (count > length)) { + offset = length; + } else { + offset = count; + } + break; + default: + DeleteScanNumberCache(numberCachePtr); + errorString = str; + goto badField; } + } - /* - * Set the result to the last position of the cursor. - */ + /* + * Set the result to the last position of the cursor. + */ - done: - Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); - DeleteScanNumberCache(numberCachePtr); - break; - } + done: + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); + DeleteScanNumberCache(numberCachePtr); + break; + } } return TCL_OK; - badValue: + badValue: Tcl_ResetResult(interp); Tcl_AppendResult(interp, "expected ", errorString, " string but got \"", errorValue, "\" instead", NULL); return TCL_ERROR; - badCount: + badCount: errorString = "missing count for \"@\" field specifier"; goto error; - badIndex: + badIndex: errorString = "not enough arguments for all format specifiers"; goto error; - badField: + badField: { Tcl_UniChar ch; char buf[TCL_UTF_MAX + 1]; @@ -1371,7 +1348,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } - error: + error: Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } @@ -1381,15 +1358,15 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) * * GetFormatSpec -- * - * This function parses the format strings used in the binary - * format and scan commands. + * This function parses the format strings used in the binary format and + * scan commands. * * Results: - * Moves the formatPtr to the start of the next command. Returns - * the current command character and count in cmdPtr and countPtr. - * The count is set to BINARY_ALL if the count character was '*' - * or BINARY_NOCOUNT if no count was specified. Returns 1 on - * success, or 0 if the string did not have a format specifier. + * Moves the formatPtr to the start of the next command. Returns the + * current command character and count in cmdPtr and countPtr. The count + * is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT + * if no count was specified. Returns 1 on success, or 0 if the string + * did not have a format specifier. * * Side effects: * None. @@ -1441,26 +1418,25 @@ GetFormatSpec(formatPtr, cmdPtr, countPtr) * * NeedReversing -- * - * This routine determines, if bytes of a number need to be - * reversed. This depends on the endiannes of the machine and - * the desired format. It is in effect a table (whose contents - * depend on the endianness of the system) describing whether a - * value needs reversing or not. Anyone porting the code to a - * big-endian platform should take care to make sure that they - * define WORDS_BIGENDIAN though this is already done by - * configure for the Unix build; little-endian platforms - * (including Windows) don't need to do anything. + * This routine determines, if bytes of a number need to be reversed. + * This depends on the endiannes of the machine and the desired format. + * It is in effect a table (whose contents depend on the endianness of + * the system) describing whether a value needs reversing or not. Anyone + * porting the code to a big-endian platform should take care to make + * sure that they define WORDS_BIGENDIAN though this is already done by + * configure for the Unix build; little-endian platforms (including + * Windows) don't need to do anything. * * Results: * 1 if reversion is required, 0 if not. * * Side effects: * None - * + * *---------------------------------------------------------------------- */ -static int +static int NeedReversing(format) int format; { @@ -1516,11 +1492,10 @@ NeedReversing(format) * * CopyNumber -- * - * This routine is called by FormatNumber and ScanNumber to copy - * a floating-point number. If required, bytes are reversed - * while copying. The behaviour is only fully defined when used - * with IEEE float and double values (guaranteed to be 4 and 8 - * bytes long, respectively.) + * This routine is called by FormatNumber and ScanNumber to copy a + * floating-point number. If required, bytes are reversed while copying. + * The behaviour is only fully defined when used with IEEE float and + * double values (guaranteed to be 4 and 8 bytes long, respectively.) * * Results: * None @@ -1531,7 +1506,7 @@ NeedReversing(format) *---------------------------------------------------------------------- */ -static void +static void CopyNumber(from, to, length, type) CONST void *from; /* source */ void *to; /* destination */ @@ -1561,7 +1536,7 @@ CopyNumber(from, to, length, type) break; } } else { - memcpy(to, from, length); + memcpy(to, from, length); } } @@ -1570,11 +1545,11 @@ CopyNumber(from, to, length, type) * * FormatNumber -- * - * This routine is called by Tcl_BinaryObjCmd to format a number - * into a location pointed at by cursor. + * This routine is called by Tcl_BinaryObjCmd to format a number into a + * location pointed at by cursor. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: * Moves the cursor to the next location to be written into. @@ -1600,9 +1575,9 @@ FormatNumber(interp, type, src, cursorPtr) case 'q': case 'Q': /* - * Double-precision floating point values. - * Tcl_GetDoubleFromObj returns TCL_ERROR for NaN, but - * we can check by comparing the object's type pointer. + * Double-precision floating point values. Tcl_GetDoubleFromObj + * returns TCL_ERROR for NaN, but we can check by comparing the + * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { @@ -1619,9 +1594,9 @@ FormatNumber(interp, type, src, cursorPtr) case 'r': case 'R': /* - * Single-precision floating point values. - * Tcl_GetDoubleFromObj returns TCL_ERROR for NaN, but - * we can check by comparing the object's type pointer. + * Single-precision floating point values. Tcl_GetDoubleFromObj + * returns TCL_ERROR for NaN, but we can check by comparing the + * object's type pointer. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { @@ -1632,9 +1607,9 @@ FormatNumber(interp, type, src, cursorPtr) } /* - * Because some compilers will generate floating point exceptions - * on an overflow cast (e.g. Borland), we restrict the values - * to the valid range for float. + * Because some compilers will generate floating point exceptions on + * an overflow cast (e.g. Borland), we restrict the values to the + * valid range for float. */ if (fabs(dvalue) > (double)FLT_MAX) { @@ -1725,7 +1700,7 @@ FormatNumber(interp, type, src, cursorPtr) } *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; - + default: Tcl_Panic("unexpected fallthrough"); return TCL_ERROR; @@ -1777,10 +1752,10 @@ ScanNumber(buffer, type, numberCachePtrPtr) switch (type) { case 'c': /* - * Characters need special handling. We want to produce a - * signed result, but on some platforms (such as AIX) chars - * are unsigned. To deal with this, check for a value that - * should be negative but isn't. + * Characters need special handling. We want to produce a signed + * result, but on some platforms (such as AIX) chars are unsigned. To + * deal with this, check for a value that should be negative but + * isn't. */ value = buffer[0]; @@ -1790,8 +1765,8 @@ ScanNumber(buffer, type, numberCachePtrPtr) goto returnNumericObject; /* - * 16-bit numeric values. We need the sign extension trick - * (see above) here as well. + * 16-bit numeric values. We need the sign extension trick (see + * above) here as well. */ case 's': @@ -1815,7 +1790,7 @@ ScanNumber(buffer, type, numberCachePtrPtr) case 'I': case 'n': if (NeedReversing(type)) { - value = (long) (buffer[0] + value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); @@ -1827,8 +1802,8 @@ ScanNumber(buffer, type, numberCachePtrPtr) } /* - * Check to see if the value was sign extended properly on - * systems where an int is more than 32-bits. + * Check to see if the value was sign extended properly on systems + * where an int is more than 32-bits. */ if ((value & (((unsigned int)1)<<31)) && (value > 0)) { @@ -1852,13 +1827,12 @@ ScanNumber(buffer, type, numberCachePtrPtr) if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { /* - * We've overflowed the cache! Someone's parsing a - * LOT of varied binary data in a single call! Bail - * out by switching back to the old behaviour for the - * rest of the scan. + * We've overflowed the cache! Someone's parsing a LOT of + * varied binary data in a single call! Bail out by switching + * back to the old behaviour for the rest of the scan. * - * Note that anyone just using the 'c' conversion (for - * bytes) cannot trigger this. + * Note that anyone just using the 'c' conversion (for bytes) + * cannot trigger this. */ DeleteScanNumberCache(tablePtr); @@ -1874,8 +1848,8 @@ ScanNumber(buffer, type, numberCachePtrPtr) } /* - * Do not cache wide (64-bit) values; they are already too - * large to use as keys. + * Do not cache wide (64-bit) values; they are already too large to + * use as keys. */ case 'w': @@ -1903,9 +1877,9 @@ ScanNumber(buffer, type, numberCachePtrPtr) return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); /* - * Do not cache double values; they are already too large to - * use as keys and the values stored are utterly incompatible - * with the integer part of the cache. + * Do not cache double values; they are already too large to use as + * keys and the values stored are utterly incompatible with the + * integer part of the cache. */ /* @@ -1935,7 +1909,7 @@ ScanNumber(buffer, type, numberCachePtrPtr) *---------------------------------------------------------------------- * * DeleteScanNumberCache -- - * + * * Deletes the hash table acting as a scan number cache. * * Results: @@ -1949,9 +1923,9 @@ ScanNumber(buffer, type, numberCachePtrPtr) static void DeleteScanNumberCache(numberCachePtr) - Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or - * NULL (when the cache has already - * been deleted due to overflow.) */ + Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or NULL + * (when the cache has already been + * deleted due to overflow.) */ { Tcl_HashEntry *hEntry; Tcl_HashSearch search; @@ -1971,3 +1945,11 @@ DeleteScanNumberCache(numberCachePtr) } Tcl_DeleteHashTable(numberCachePtr); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index c2fae75..a3a6279 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1,4 +1,4 @@ -/* +/* * tclCmdAH.c -- * * This file contains the top-level command routines for most of @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdAH.c,v 1.63 2005/06/17 23:41:03 dkf Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.64 2005/07/17 21:17:30 dkf Exp $ */ #include "tclInt.h" @@ -35,12 +35,12 @@ static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp, * * Tcl_BreakObjCmd -- * - * This procedure is invoked to process the "break" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "break" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "break" or the name - * to which "break" was renamed: e.g., "set z break; $z" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "break" or the name to + * which "break" was renamed: e.g., "set z break; $z" * * Results: * A standard Tcl result. @@ -71,8 +71,8 @@ Tcl_BreakObjCmd(dummy, interp, objc, objv) * * Tcl_CaseObjCmd -- * - * This procedure is invoked to process the "case" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "case" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -116,8 +116,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) caseObjv = objv + i; /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. */ if (caseObjc == 1) { @@ -140,8 +140,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } /* - * Check for special case of single pattern (no list) with - * no backslash sequences. + * Check for special case of single pattern (no list) with no + * backslash sequences. */ pat = TclGetString(caseObjv[i]); @@ -162,8 +162,8 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } /* - * Break up pattern lists, then check each of the patterns - * in the list. + * Break up pattern lists, then check each of the patterns in the + * list. */ result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); @@ -182,7 +182,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) } } - match: + match: if (body != -1) { armPtr = caseObjv[body - 1]; result = Tcl_EvalObjEx(interp, caseObjv[body], 0); @@ -209,7 +209,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv) * * Tcl_CatchObjCmd -- * - * This object-based procedure is invoked to process the "catch" Tcl + * This object-based procedure is invoked to process the "catch" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -251,6 +251,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) /* * We disable catch in interpreters where the limit has been exceeded. */ + if (Tcl_LimitExceeded(interp)) { char msg[32 + TCL_INTEGER_SPACE]; @@ -263,8 +264,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL, Tcl_GetObjResult(interp), 0)) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "couldn't save command result in variable", NULL); + Tcl_AppendResult(interp, + "couldn't save command result in variable", NULL); return TCL_ERROR; } } @@ -275,7 +276,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(options); Tcl_ResetResult(interp); Tcl_AppendResult(interp, - "couldn't save return options in variable", NULL); + "couldn't save return options in variable", NULL); return TCL_ERROR; } } @@ -290,8 +291,8 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) * * Tcl_CdObjCmd -- * - * This procedure is invoked to process the "cd" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "cd" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -376,12 +377,12 @@ Tcl_ConcatObjCmd(dummy, interp, objc, objv) * * Tcl_ContinueObjCmd -- * - * This procedure is invoked to process the "continue" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "continue" Tcl command. See + * the user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "continue" or the name - * to which "continue" was renamed: e.g., "set z continue; $z" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "continue" or the name to + * which "continue" was renamed: e.g., "set z continue; $z" * * Results: * A standard Tcl result. @@ -430,10 +431,7 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int index, length; - Tcl_Encoding encoding; - char *stringPtr; - Tcl_DString ds; + int index; static CONST char *optionStrings[] = { "convertfrom", "convertto", "names", "system", @@ -445,7 +443,7 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { @@ -453,76 +451,78 @@ Tcl_EncodingObjCmd(dummy, interp, objc, objv) } switch ((enum options) index) { - case ENC_CONVERTTO: - case ENC_CONVERTFROM: { - Tcl_Obj *data; - if (objc == 3) { - encoding = Tcl_GetEncoding(interp, NULL); - data = objv[2]; - } else if (objc == 4) { - if (TclGetEncodingFromObj(interp, objv[2], &encoding) - != TCL_OK) { - return TCL_ERROR; - } - data = objv[3]; - } else { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + case ENC_CONVERTTO: + case ENC_CONVERTFROM: { + Tcl_Obj *data; + Tcl_DString ds; + Tcl_Encoding encoding; + int length; + char *stringPtr; + + if (objc == 3) { + encoding = Tcl_GetEncoding(interp, NULL); + data = objv[2]; + } else if (objc == 4) { + if (TclGetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) { return TCL_ERROR; } + data = objv[3]; + } else { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data"); + return TCL_ERROR; + } - if ((enum options) index == ENC_CONVERTFROM) { - /* - * Treat the string as binary data. - */ + if ((enum options) index == ENC_CONVERTFROM) { + /* + * Treat the string as binary data. + */ - stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); - Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); + stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds); - /* - * Note that we cannot use Tcl_DStringResult here because - * it will truncate the string at the first null byte. - */ + /* + * Note that we cannot use Tcl_DStringResult here because it will + * truncate the string at the first null byte. + */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - } else { - /* - * Store the result as binary data. - */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } else { + /* + * Store the result as binary data. + */ - stringPtr = Tcl_GetStringFromObj(data, &length); - Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - } + stringPtr = Tcl_GetStringFromObj(data, &length); + Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + } - Tcl_FreeEncoding(encoding); - break; + Tcl_FreeEncoding(encoding); + break; + } + case ENC_NAMES: + if (objc > 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } - case ENC_NAMES: { - if (objc > 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_GetEncodingNames(interp); - break; + Tcl_GetEncodingNames(interp); + break; + case ENC_SYSTEM: + if (objc > 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); + return TCL_ERROR; } - case ENC_SYSTEM: { - if (objc > 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?encoding?"); - return TCL_ERROR; - } - if (objc == 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - Tcl_GetEncodingName(NULL), -1)); - } else { - return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); - } - break; + if (objc == 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + Tcl_GetEncodingName(NULL), -1)); + } else { + return Tcl_SetSystemEncoding(interp, TclGetString(objv[2])); } + break; } return TCL_OK; } @@ -572,8 +572,8 @@ TclEncodingDirsObjCmd(dummy, interp, objc, objv) * * Tcl_ErrorObjCmd -- * - * This procedure is invoked to process the "error" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "error" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -622,7 +622,7 @@ Tcl_ErrorObjCmd(dummy, interp, objc, objv) * * Tcl_EvalObjCmd -- * - * This object-based procedure is invoked to process the "eval" Tcl + * This object-based procedure is invoked to process the "eval" Tcl * command. See the user documentation for details on what it does. * * Results: @@ -655,8 +655,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) } else { /* * More than one argument: concatenate them together with spaces - * between, then evaluate the result. Tcl_EvalObjEx will delete - * the object when it decrements its refcount after eval'ing it. + * between, then evaluate the result. Tcl_EvalObjEx will delete the + * object when it decrements its refcount after eval'ing it. */ objPtr = Tcl_ConcatObj(objc-1, objv+1); result = Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_DIRECT); @@ -675,8 +675,8 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv) * * Tcl_ExitObjCmd -- * - * This procedure is invoked to process the "exit" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "exit" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -721,8 +721,8 @@ Tcl_ExitObjCmd(dummy, interp, objc, objv) * command. See the user documentation for details on what it does. * * With the bytecode compiler, this procedure is called in two - * circumstances: 1) to execute expr commands that are too complicated - * or too unsafe to try compiling directly into an inline sequence of + * circumstances: 1) to execute expr commands that are too complicated or + * too unsafe to try compiling directly into an inline sequence of * instructions, and 2) to execute commands where the command name is * computed at runtime and is "expr" or the name to which "expr" was * renamed (e.g., "set z expr; $z 2+3") @@ -743,7 +743,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ +{ register Tcl_Obj *objPtr; Tcl_Obj *resultPtr; int result; @@ -771,13 +771,12 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv) * * Tcl_FileObjCmd -- * - * This procedure is invoked to process the "file" Tcl command. - * See the user documentation for details on what it does. - * PLEASE NOTE THAT THIS FAILS WITH FILENAMES AND PATHS WITH - * EMBEDDED NULLS. - * With the object-based Tcl_FS APIs, the above NOTE may no - * longer be true. In any case this assertion should be tested. - * + * This procedure is invoked to process the "file" Tcl command. See the + * user documentation for details on what it does. PLEASE NOTE THAT THIS + * FAILS WITH FILENAMES AND PATHS WITH EMBEDDED NULLS. With the + * object-based Tcl_FS APIs, the above NOTE may no longer be true. In any + * case this assertion should be tested. + * * Results: * A standard Tcl result. * @@ -797,20 +796,20 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) { int index; -/* - * This list of constants should match the fileOption string array below. - */ + /* + * This list of constants should match the fileOption string array below. + */ static CONST char *fileOptions[] = { "atime", "attributes", "channels", "copy", "delete", "dirname", "executable", "exists", "extension", "isdirectory", "isfile", "join", "link", - "lstat", "mtime", "mkdir", "nativename", + "lstat", "mtime", "mkdir", "nativename", "normalize", "owned", "pathtype", "readable", "readlink", "rename", - "rootname", "separator", "size", "split", - "stat", "system", + "rootname", "separator", "size", "split", + "stat", "system", "tail", "type", "volumes", "writable", (char *) NULL }; @@ -818,18 +817,18 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) FCMD_ATIME, FCMD_ATTRIBUTES, FCMD_CHANNELS, FCMD_COPY, FCMD_DELETE, FCMD_DIRNAME, FCMD_EXECUTABLE, FCMD_EXISTS, FCMD_EXTENSION, - FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, - FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, - FCMD_NORMALIZE, FCMD_OWNED, + FCMD_ISDIRECTORY, FCMD_ISFILE, FCMD_JOIN, FCMD_LINK, + FCMD_LSTAT, FCMD_MTIME, FCMD_MKDIR, FCMD_NATIVENAME, + FCMD_NORMALIZE, FCMD_OWNED, FCMD_PATHTYPE, FCMD_READABLE, FCMD_READLINK, FCMD_RENAME, - FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, - FCMD_STAT, FCMD_SYSTEM, + FCMD_ROOTNAME, FCMD_SEPARATOR, FCMD_SIZE, FCMD_SPLIT, + FCMD_STAT, FCMD_SYSTEM, FCMD_TAIL, FCMD_TYPE, FCMD_VOLUMES, FCMD_WRITABLE }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], fileOptions, "option", 0, &index) != TCL_OK) { @@ -837,565 +836,580 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) } switch ((enum options) index) { - case FCMD_ATIME: { - Tcl_StatBuf buf; - struct utimbuf tval; + case FCMD_ATIME: { + Tcl_StatBuf buf; + struct utimbuf tval; - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 4) { + /* + * Need separate variable for reading longs from an object on + * 64-bit platforms. [Bug #698146] + */ + + long newTime; + + if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + + tval.actime = newTime; + tval.modtime = buf.st_mtime; + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendResult(interp, + "could not set access time for file \"", + TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), + (char *) NULL); return TCL_ERROR; } - if (objc == 4) { - /* - * Need separate variable for reading longs from an - * object on 64-bit platforms. [Bug #698146] - */ - long newTime; - if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, + * fs's like FAT don't even know what atime is. + */ - tval.actime = newTime; - tval.modtime = buf.st_mtime; - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, - "could not set access time for file \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - /* - * Do another stat to ensure that the we return the - * new recognized atime - hopefully the same as the - * one we sent in. However, fs's like FAT don't - * even know what atime is. - */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); + } + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_atime)); + return TCL_OK; + } + case FCMD_ATTRIBUTES: + return TclFileAttrsCmd(interp, objc, objv); + case FCMD_CHANNELS: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); + return TCL_ERROR; + } + return Tcl_GetChannelNamesEx(interp, + ((objc == 2) ? NULL : TclGetString(objv[2]))); + case FCMD_COPY: + return TclFileCopyCmd(interp, objc, objv); + case FCMD_DELETE: + return TclFileDeleteCmd(interp, objc, objv); + case FCMD_DIRNAME: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); + if (dirPtr == NULL) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); return TCL_OK; } - case FCMD_ATTRIBUTES: - return TclFileAttrsCmd(interp, objc, objv); - case FCMD_CHANNELS: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?pattern?"); - return TCL_ERROR; - } - return Tcl_GetChannelNamesEx(interp, - ((objc == 2) ? NULL : TclGetString(objv[2]))); - case FCMD_COPY: - return TclFileCopyCmd(interp, objc, objv); - case FCMD_DELETE: - return TclFileDeleteCmd(interp, objc, objv); - case FCMD_DIRNAME: { - Tcl_Obj *dirPtr; - - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME); - if (dirPtr == NULL) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } + } + case FCMD_EXECUTABLE: + if (objc != 3) { + goto only3Args; } - case FCMD_EXECUTABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], X_OK); - case FCMD_EXISTS: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], F_OK); - case FCMD_EXTENSION: { - Tcl_Obj *ext; - - if (objc != 3) { - goto only3Args; - } - ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); - if (ext != NULL) { - Tcl_SetObjResult(interp, ext); - Tcl_DecrRefCount(ext); - return TCL_OK; - } else { - return TCL_ERROR; - } + return CheckAccess(interp, objv[2], X_OK); + case FCMD_EXISTS: + if (objc != 3) { + goto only3Args; } - case FCMD_ISDIRECTORY: { - int value; - Tcl_StatBuf buf; + return CheckAccess(interp, objv[2], F_OK); + case FCMD_EXTENSION: { + Tcl_Obj *ext; - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISDIR(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + if (objc != 3) { + goto only3Args; + } + ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION); + if (ext != NULL) { + Tcl_SetObjResult(interp, ext); + Tcl_DecrRefCount(ext); return TCL_OK; + } else { + return TCL_ERROR; } - case FCMD_ISFILE: { - int value; - Tcl_StatBuf buf; + } + case FCMD_ISDIRECTORY: { + int value; + Tcl_StatBuf buf; - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - value = S_ISREG(buf.st_mode); - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; + if (objc != 3) { + goto only3Args; } - case FCMD_JOIN: { - Tcl_Obj *resObj; + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISDIR(buf.st_mode); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + } + case FCMD_ISFILE: { + int value; + Tcl_StatBuf buf; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); - return TCL_ERROR; - } - resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); - Tcl_SetObjResult(interp, resObj); - return TCL_OK; + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + value = S_ISREG(buf.st_mode); } - case FCMD_LINK: { - Tcl_Obj *contents; - int index; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + } + case FCMD_JOIN: { + Tcl_Obj *resObj; - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-linktype? linkname ?target?"); - return TCL_ERROR; - } + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + resObj = Tcl_FSJoinToPath(NULL, objc - 2, objv + 2); + Tcl_SetObjResult(interp, resObj); + return TCL_OK; + } + case FCMD_LINK: { + Tcl_Obj *contents; + int index; + + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-linktype? linkname ?target?"); + return TCL_ERROR; + } - /* Index of the 'source' argument */ + /* + * Index of the 'source' argument. + */ + + if (objc == 5) { + index = 3; + } else { + index = 2; + } + + if (objc > 3) { + int linkAction; if (objc == 5) { - index = 3; + /* + * We have a '-linktype' argument. + */ + + static CONST char *linkTypes[] = { + "-symbolic", "-hard", NULL + }; + if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, "switch", + 0, &linkAction) != TCL_OK) { + return TCL_ERROR; + } + if (linkAction == 0) { + linkAction = TCL_CREATE_SYMBOLIC_LINK; + } else { + linkAction = TCL_CREATE_HARD_LINK; + } } else { - index = 2; + linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; + } + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { + return TCL_ERROR; } - if (objc > 3) { - int linkAction; - if (objc == 5) { - /* We have a '-linktype' argument */ - static CONST char *linkTypes[] = { - "-symbolic", "-hard", NULL - }; - if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, - "switch", 0, &linkAction) != TCL_OK) { + /* + * Create link from source to target. + */ + + contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); + if (contents == NULL) { + /* + * We handle three common error cases specially, and for all + * other errors, we use the standard posix error message. + */ + + if (errno == EEXIST) { + Tcl_AppendResult(interp, "could not create new link \"", + TclGetString(objv[index]), + "\": that path already exists", (char *) NULL); + } else if (errno == ENOENT) { + /* + * There are two cases here: either the target doesn't + * exist, or the directory of the src doesn't exist. + */ + + int access; + Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], + TCL_PATH_DIRNAME); + + if (dirPtr == NULL) { return TCL_ERROR; } - if (linkAction == 0) { - linkAction = TCL_CREATE_SYMBOLIC_LINK; - } else { - linkAction = TCL_CREATE_HARD_LINK; - } - } else { - linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK; - } - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - /* Create link from source to target */ - contents = Tcl_FSLink(objv[index], objv[index+1], linkAction); - if (contents == NULL) { - /* - * We handle three common error cases specially, and - * for all other errors, we use the standard posix - * error message. - */ - if (errno == EEXIST) { + access = Tcl_FSAccess(dirPtr, F_OK); + Tcl_DecrRefCount(dirPtr); + if (access != 0) { Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": that path already exists", (char *) NULL); - } else if (errno == ENOENT) { - /* - * There are two cases here: either the target - * doesn't exist, or the directory of the src - * doesn't exist. - */ - int access; - Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], - TCL_PATH_DIRNAME); - if (dirPtr == NULL) { - return TCL_ERROR; - } - access = Tcl_FSAccess(dirPtr, F_OK); - Tcl_DecrRefCount(dirPtr); - if (access != 0) { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": no such file or directory", - (char *) NULL); - } else { - Tcl_AppendResult(interp, - "could not create new link \"", - TclGetString(objv[index]), - "\": target \"", - TclGetString(objv[index+1]), - "\" doesn't exist", - (char *) NULL); - } + "could not create new link \"", + TclGetString(objv[index]), + "\": no such file or directory", + (char *) NULL); } else { Tcl_AppendResult(interp, "could not create new link \"", - TclGetString(objv[index]), "\" pointing to \"", - TclGetString(objv[index+1]), "\": ", - Tcl_PosixError(interp), (char *) NULL); + TclGetString(objv[index]), "\": target \"", + TclGetString(objv[index+1]), + "\" doesn't exist", (char *) NULL); } - return TCL_ERROR; - } - } else { - if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { - return TCL_ERROR; - } - /* Read link */ - contents = Tcl_FSLink(objv[index], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not read link \"", - TclGetString(objv[index]), "\": ", + } else { + Tcl_AppendResult(interp, + "could not create new link \"", + TclGetString(objv[index]), "\" pointing to \"", + TclGetString(objv[index+1]), "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; } - } - Tcl_SetObjResult(interp, contents); - if (objc == 3) { - /* - * If we are reading a link, we need to free this - * result refCount. If we are creating a link, this - * will just be objv[index+1], and so we don't own it. - */ - Tcl_DecrRefCount(contents); - } - return TCL_OK; - } - case FCMD_LSTAT: { - Tcl_StatBuf buf; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name varName"); return TCL_ERROR; } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + } else { + if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - return StoreStatData(interp, objv[3], &buf); - } - case FCMD_MTIME: { - Tcl_StatBuf buf; - struct utimbuf tval; - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + /* + * Read link + */ + + contents = Tcl_FSLink(objv[index], NULL, 0); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not read link \"", + TclGetString(objv[index]), "\": ", + Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } - if (objc == 4) { - /* - * Need separate variable for reading longs from an - * object on 64-bit platforms. [Bug #698146] - */ - long newTime; + } + Tcl_SetObjResult(interp, contents); + if (objc == 3) { + /* + * If we are reading a link, we need to free this result refCount. + * If we are creating a link, this will just be objv[index+1], and + * so we don't own it. + */ - if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { - return TCL_ERROR; - } + Tcl_DecrRefCount(contents); + } + return TCL_OK; + } + case FCMD_LSTAT: { + Tcl_StatBuf buf; - tval.actime = buf.st_atime; - tval.modtime = newTime; - if (Tcl_FSUtime(objv[2], &tval) != 0) { - Tcl_AppendResult(interp, - "could not set modification time for file \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - /* - * Do another stat to ensure that the we return the - * new recognized atime - hopefully the same as the - * one we sent in. However, fs's like FAT don't - * even know what atime is. - */ - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - } - Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); - return TCL_OK; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "name varName"); + return TCL_ERROR; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + return StoreStatData(interp, objv[3], &buf); + } + case FCMD_MTIME: { + Tcl_StatBuf buf; + struct utimbuf tval; + + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?time?"); + return TCL_ERROR; } - case FCMD_MKDIR: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + if (objc == 4) { + /* + * Need separate variable for reading longs from an object on + * 64-bit platforms. [Bug #698146] + */ + + long newTime; + + if (Tcl_GetLongFromObj(interp, objv[3], &newTime) != TCL_OK) { return TCL_ERROR; } - return TclFileMakeDirsCmd(interp, objc, objv); - case FCMD_NATIVENAME: { - CONST char *fileName; - Tcl_DString ds; - if (objc != 3) { - goto only3Args; - } - fileName = TclGetString(objv[2]); - fileName = Tcl_TranslateFileName(interp, fileName, &ds); - if (fileName == NULL) { + tval.actime = buf.st_atime; + tval.modtime = newTime; + if (Tcl_FSUtime(objv[2], &tval) != 0) { + Tcl_AppendResult(interp, + "could not set modification time for file \"", + TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), + (char *) NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, - Tcl_DStringLength(&ds))); - Tcl_DStringFree(&ds); - return TCL_OK; - } - case FCMD_NORMALIZE: { - Tcl_Obj *fileName; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "filename"); + /* + * Do another stat to ensure that the we return the new recognized + * atime - hopefully the same as the one we sent in. However, fs's + * like FAT don't even know what atime is. + */ + + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { return TCL_ERROR; } + } + Tcl_SetObjResult(interp, Tcl_NewLongObj((long) buf.st_mtime)); + return TCL_OK; + } + case FCMD_MKDIR: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?"); + return TCL_ERROR; + } + return TclFileMakeDirsCmd(interp, objc, objv); + case FCMD_NATIVENAME: { + CONST char *fileName; + Tcl_DString ds; - fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); - if (fileName == NULL) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, fileName); - return TCL_OK; + if (objc != 3) { + goto only3Args; + } + fileName = TclGetString(objv[2]); + fileName = Tcl_TranslateFileName(interp, fileName, &ds); + if (fileName == NULL) { + return TCL_ERROR; } - case FCMD_OWNED: { - int value; - Tcl_StatBuf buf; + Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName, + Tcl_DStringLength(&ds))); + Tcl_DStringFree(&ds); + return TCL_OK; + } + case FCMD_NORMALIZE: { + Tcl_Obj *fileName; - if (objc != 3) { - goto only3Args; - } - value = 0; - if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { - /* - * For Windows, there are no user ids - * associated with a file, so we always return 1. - */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "filename"); + return TCL_ERROR; + } + + fileName = Tcl_FSGetNormalizedPath(interp, objv[2]); + if (fileName == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, fileName); + return TCL_OK; + } + case FCMD_OWNED: { + int value; + Tcl_StatBuf buf; + + if (objc != 3) { + goto only3Args; + } + value = 0; + if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) { + /* + * For Windows, there are no user ids associated with a file, so + * we always return 1. + */ #if defined(__WIN32__) - value = 1; + value = 1; #else - value = (geteuid() == buf.st_uid); + value = (geteuid() == buf.st_uid); #endif - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); - return TCL_OK; } - case FCMD_PATHTYPE: - if (objc != 3) { - goto only3Args; - } - switch (Tcl_FSGetPathType(objv[2])) { - case TCL_PATH_ABSOLUTE: - Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1)); - break; - case TCL_PATH_RELATIVE: - Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1)); - break; - case TCL_PATH_VOLUME_RELATIVE: - Tcl_SetObjResult(interp, - Tcl_NewStringObj("volumerelative", -1)); - break; - } - return TCL_OK; - case FCMD_READABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], R_OK); - case FCMD_READLINK: { - Tcl_Obj *contents; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); + return TCL_OK; + } + case FCMD_PATHTYPE: + if (objc != 3) { + goto only3Args; + } + switch (Tcl_FSGetPathType(objv[2])) { + case TCL_PATH_ABSOLUTE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("absolute", -1)); + break; + case TCL_PATH_RELATIVE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("relative", -1)); + break; + case TCL_PATH_VOLUME_RELATIVE: + Tcl_SetObjResult(interp, Tcl_NewStringObj("volumerelative", -1)); + break; + } + return TCL_OK; + case FCMD_READABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], R_OK); + case FCMD_READLINK: { + Tcl_Obj *contents; - if (objc != 3) { - goto only3Args; - } + if (objc != 3) { + goto only3Args; + } - if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) { + return TCL_ERROR; + } - contents = Tcl_FSLink(objv[2], NULL, 0); + contents = Tcl_FSLink(objv[2], NULL, 0); - if (contents == NULL) { - Tcl_AppendResult(interp, "could not readlink \"", - TclGetString(objv[2]), "\": ", - Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, contents); - Tcl_DecrRefCount(contents); + if (contents == NULL) { + Tcl_AppendResult(interp, "could not readlink \"", + TclGetString(objv[2]), "\": ", Tcl_PosixError(interp), + (char *) NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, contents); + Tcl_DecrRefCount(contents); + return TCL_OK; + } + case FCMD_RENAME: + return TclFileRenameCmd(interp, objc, objv); + case FCMD_ROOTNAME: { + Tcl_Obj *root; + + if (objc != 3) { + goto only3Args; + } + root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); + if (root != NULL) { + Tcl_SetObjResult(interp, root); + Tcl_DecrRefCount(root); return TCL_OK; + } else { + return TCL_ERROR; } - case FCMD_RENAME: - return TclFileRenameCmd(interp, objc, objv); - case FCMD_ROOTNAME: { - Tcl_Obj *root; + } + case FCMD_SEPARATOR: + if ((objc < 2) || (objc > 3)) { + Tcl_WrongNumArgs(interp, 2, objv, "?name?"); + return TCL_ERROR; + } + if (objc == 2) { + char *separator = NULL; /* lint */ - if (objc != 3) { - goto only3Args; + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } - root = TclPathPart(interp, objv[2], TCL_PATH_ROOT); - if (root != NULL) { - Tcl_SetObjResult(interp, root); - Tcl_DecrRefCount(root); - return TCL_OK; + Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); + } else { + Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); + if (separatorObj != NULL) { + Tcl_SetObjResult(interp, separatorObj); } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("Unrecognised path",-1)); return TCL_ERROR; } } - case FCMD_SEPARATOR: - if ((objc < 2) || (objc > 3)) { - Tcl_WrongNumArgs(interp, 2, objv, "?name?"); - return TCL_ERROR; - } - if (objc == 2) { - char *separator = NULL; /* lint */ - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1)); - } else { - Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]); - if (separatorObj != NULL) { - Tcl_SetObjResult(interp, separatorObj); - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Unrecognised path",-1)); - return TCL_ERROR; - } - } - return TCL_OK; - case FCMD_SIZE: { - Tcl_StatBuf buf; + return TCL_OK; + case FCMD_SIZE: { + Tcl_StatBuf buf; - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, - Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); - return TCL_OK; + if (objc != 3) { + goto only3Args; } - case FCMD_SPLIT: { - Tcl_Obj *res; + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, + Tcl_NewWideIntObj((Tcl_WideInt) buf.st_size)); + return TCL_OK; + } + case FCMD_SPLIT: { + Tcl_Obj *res; - if (objc != 3) { - goto only3Args; - } - res = Tcl_FSSplitPath(objv[2], NULL); - if (res == NULL) { - if (interp != NULL) { - Tcl_AppendResult(interp, "could not read \"", + if (objc != 3) { + goto only3Args; + } + res = Tcl_FSSplitPath(objv[2], NULL); + if (res == NULL) { + if (interp != NULL) { + Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[2]), "\": no such file or directory", (char *) NULL); - } - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, res); - return TCL_OK; } + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, res); + return TCL_OK; } - case FCMD_STAT: { - Tcl_StatBuf buf; + } + case FCMD_STAT: { + Tcl_StatBuf buf; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); - return TCL_ERROR; - } - if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { - return TCL_ERROR; - } - return StoreStatData(interp, objv[3], &buf); + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "stat name varName"); + return TCL_ERROR; } - case FCMD_SYSTEM: { - Tcl_Obj* fsInfo; - - if (objc != 3) { - goto only3Args; - } - fsInfo = Tcl_FSFileSystemInfo(objv[2]); - if (fsInfo != NULL) { - Tcl_SetObjResult(interp, fsInfo); - return TCL_OK; - } else { - Tcl_SetObjResult(interp, - Tcl_NewStringObj("Unrecognised path",-1)); - return TCL_ERROR; - } + if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) { + return TCL_ERROR; } - case FCMD_TAIL: { - Tcl_Obj *dirPtr; + return StoreStatData(interp, objv[3], &buf); + } + case FCMD_SYSTEM: { + Tcl_Obj* fsInfo; - if (objc != 3) { - goto only3Args; - } - dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); - if (dirPtr == NULL) { - return TCL_ERROR; - } else { - Tcl_SetObjResult(interp, dirPtr); - Tcl_DecrRefCount(dirPtr); - return TCL_OK; - } + if (objc != 3) { + goto only3Args; } - case FCMD_TYPE: { - Tcl_StatBuf buf; - - if (objc != 3) { - goto only3Args; - } - if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_NewStringObj( - GetTypeFromMode((unsigned short) buf.st_mode), -1)); + fsInfo = Tcl_FSFileSystemInfo(objv[2]); + if (fsInfo != NULL) { + Tcl_SetObjResult(interp, fsInfo); return TCL_OK; + } else { + Tcl_SetObjResult(interp, Tcl_NewStringObj("Unrecognised path",-1)); + return TCL_ERROR; } - case FCMD_VOLUMES: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + } + case FCMD_TAIL: { + Tcl_Obj *dirPtr; + + if (objc != 3) { + goto only3Args; + } + dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL); + if (dirPtr == NULL) { + return TCL_ERROR; + } else { + Tcl_SetObjResult(interp, dirPtr); + Tcl_DecrRefCount(dirPtr); return TCL_OK; - case FCMD_WRITABLE: - if (objc != 3) { - goto only3Args; - } - return CheckAccess(interp, objv[2], W_OK); + } + } + case FCMD_TYPE: { + Tcl_StatBuf buf; + + if (objc != 3) { + goto only3Args; + } + if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewStringObj( + GetTypeFromMode((unsigned short) buf.st_mode), -1)); + return TCL_OK; + } + case FCMD_VOLUMES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_FSListVolumes()); + return TCL_OK; + case FCMD_WRITABLE: + if (objc != 3) { + goto only3Args; + } + return CheckAccess(interp, objv[2], W_OK); } - only3Args: + only3Args: Tcl_WrongNumArgs(interp, 2, objv, "name"); return TCL_ERROR; } @@ -1405,12 +1419,12 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) * * CheckAccess -- * - * Utility procedure used by Tcl_FileObjCmd() to query file - * attributes available through the access() system call. + * Utility procedure used by Tcl_FileObjCmd() to query file attributes + * available through the access() system call. * * Results: - * Always returns TCL_OK. Sets interp's result to boolean true or - * false depending on whether the file has the specified attribute. + * Always returns TCL_OK. Sets interp's result to boolean true or false + * depending on whether the file has the specified attribute. * * Side effects: * None. @@ -1420,7 +1434,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv) static int CheckAccess(interp, pathPtr, mode) - Tcl_Interp *interp; /* Interp for status return. Must not be + Tcl_Interp *interp; /* Interp for status return. Must not be * NULL. */ Tcl_Obj *pathPtr; /* Name of file to check. */ int mode; /* Attribute to check; passed as argument to @@ -1443,14 +1457,14 @@ CheckAccess(interp, pathPtr, mode) * * GetStatBuf -- * - * Utility procedure used by Tcl_FileObjCmd() to query file - * attributes available through the stat() or lstat() system call. + * Utility procedure used by Tcl_FileObjCmd() to query file attributes + * available through the stat() or lstat() system call. * * Results: - * The return value is TCL_OK if the specified file exists and can - * be stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an - * error message is left in interp's result. If TCL_OK is returned, - * *statPtr is filled with information about the specified file. + * The return value is TCL_OK if the specified file exists and can be + * stat'ed, TCL_ERROR otherwise. If TCL_ERROR is returned, an error + * message is left in interp's result. If TCL_OK is returned, *statPtr + * is filled with information about the specified file. * * Side effects: * None. @@ -1491,13 +1505,13 @@ GetStatBuf(interp, pathPtr, statProc, statPtr) * * StoreStatData -- * - * This is a utility procedure that breaks out the fields of a - * "stat" structure and stores them in textual form into the - * elements of an associative array. + * This is a utility procedure that breaks out the fields of a "stat" + * structure and stores them in textual form into the elements of an + * associative array. * * Results: - * Returns a standard Tcl return value. If an error occurs then - * a message is left in interp's result. + * Returns a standard Tcl return value. If an error occurs then a + * message is left in interp's result. * * Side effects: * Elements of the associative array given by "varName" are modified. @@ -1510,8 +1524,8 @@ StoreStatData(interp, varName, statPtr) Tcl_Interp *interp; /* Interpreter for error reports. */ Tcl_Obj *varName; /* Name of associative array variable * in which to store stat results. */ - Tcl_StatBuf *statPtr; /* Pointer to buffer containing - * stat data to store in varName. */ + Tcl_StatBuf *statPtr; /* Pointer to buffer containing stat + * data to store in varName. */ { Tcl_Obj *field = Tcl_NewObj(); Tcl_Obj *value; @@ -1520,40 +1534,43 @@ StoreStatData(interp, varName, statPtr) /* * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! * - * Might be a better idea to call Tcl_SetVar2Ex() instead so we - * don't have to make assumptions that might go wrong later. + * Might be a better idea to call Tcl_SetVar2Ex() instead so we don't have + * to make assumptions that might go wrong later. */ + #define STORE_ARY(fieldName, object) \ Tcl_SetStringObj(field, (fieldName), -1); \ value = (object); \ - if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \ + if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG)==NULL) { \ Tcl_DecrRefCount(field); \ Tcl_DecrRefCount(value); \ return TCL_ERROR; \ } Tcl_IncrRefCount(field); - STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + /* - * Watch out porters; the inode is meant to be an *unsigned* value, - * so the cast might fail when there isn't a real arithmentic 'long - * long' type... + * Watch out porters; the inode is meant to be an *unsigned* value, so the + * cast might fail when there isn't a real arithmentic 'long long' type... */ - STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); - STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); + + STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); + STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); + STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_ST_BLOCKS - STORE_ARY("blocks",Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); + STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif - STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); - STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); - STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); + STORE_ARY("atime", Tcl_NewLongObj((long)statPtr->st_atime)); + STORE_ARY("mtime", Tcl_NewLongObj((long)statPtr->st_mtime)); + STORE_ARY("ctime", Tcl_NewLongObj((long)statPtr->st_ctime)); mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewIntObj(mode)); - STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); + STORE_ARY("mode", Tcl_NewIntObj(mode)); + STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY + Tcl_DecrRefCount(field); return TCL_OK; } @@ -1563,8 +1580,7 @@ StoreStatData(interp, varName, statPtr) * * GetTypeFromMode -- * - * Given a mode word, returns a string identifying the type of a - * file. + * Given a mode word, returns a string identifying the type of a file. * * Results: * A static text string giving the file type from mode. @@ -1606,44 +1622,44 @@ GetTypeFromMode(mode) * * Tcl_ForObjCmd -- * - * This procedure is invoked to process the "for" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "for" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "for" or the name - * to which "for" was renamed: e.g., + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "for" or the name to which + * "for" was renamed: e.g., * "set z for; $z {set i 0} {$i<100} {incr i} {puts $i}" * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: - * See the user documentation. + * See the user documentation. * *---------------------------------------------------------------------- */ - /* ARGSUSED */ + /* ARGSUSED */ int Tcl_ForObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result, value; if (objc != 5) { - Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "start test next command"); + return TCL_ERROR; } result = Tcl_EvalObjEx(interp, objv[1], 0); if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); - } - return result; + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" initial command)"); + } + return result; } while (1) { /* @@ -1653,38 +1669,38 @@ Tcl_ForObjCmd(dummy, interp, objc, objv) */ Tcl_ResetResult(interp); - result = Tcl_ExprBooleanObj(interp, objv[2], &value); - if (result != TCL_OK) { - return result; - } - if (!value) { - break; - } - result = Tcl_EvalObjEx(interp, objv[4], 0); - if ((result != TCL_OK) && (result != TCL_CONTINUE)) { - if (result == TCL_ERROR) { - char msg[32 + TCL_INTEGER_SPACE]; - - sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); - Tcl_AddErrorInfo(interp, msg); - } - break; - } - result = Tcl_EvalObjEx(interp, objv[3], 0); + result = Tcl_ExprBooleanObj(interp, objv[2], &value); + if (result != TCL_OK) { + return result; + } + if (!value) { + break; + } + result = Tcl_EvalObjEx(interp, objv[4], 0); + if ((result != TCL_OK) && (result != TCL_CONTINUE)) { + if (result == TCL_ERROR) { + char msg[32 + TCL_INTEGER_SPACE]; + + sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine); + Tcl_AddErrorInfo(interp, msg); + } + break; + } + result = Tcl_EvalObjEx(interp, objv[3], 0); if (result == TCL_BREAK) { - break; - } else if (result != TCL_OK) { - if (result == TCL_ERROR) { - Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); - } - return result; - } + break; + } else if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)"); + } + return result; + } } if (result == TCL_BREAK) { - result = TCL_OK; + result = TCL_OK; } if (result == TCL_OK) { - Tcl_ResetResult(interp); + Tcl_ResetResult(interp); } return result; } @@ -1722,10 +1738,10 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_Obj *bodyPtr; /* - * We copy the argument object pointers into a local array to avoid - * the problem that "objv" might become invalid. It is a pointer into - * the evaluation stack and that stack might be grown and reallocated - * if the loop body requires a large amount of stack space. + * We copy the argument object pointers into a local array to avoid the + * problem that "objv" might become invalid. It is a pointer into the + * evaluation stack and that stack might be grown and reallocated if the + * loop body requires a large amount of stack space. */ #define NUM_ARGS 9 @@ -1752,23 +1768,23 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) } /* - * Create the object argument array "argObjv". Make sure argObjv is - * large enough to hold the objc arguments. + * Create the object argument array "argObjv". Make sure argObjv is large + * enough to hold the objc arguments. */ if (objc > NUM_ARGS) { argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *)); } - for (i = 0; i < objc; i++) { + for (i=0 ; ierrorLine); @@ -1897,7 +1911,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) Tcl_ResetResult(interp); } - done: + done: if (numLists > STATIC_LIST_SIZE) { ckfree((char *) index); ckfree((char *) varcList); @@ -1918,8 +1932,8 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv) * * Tcl_FormatObjCmd -- * - * This procedure is invoked to process the "format" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "format" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1958,8 +1972,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) * it's a double value. */ Tcl_WideInt wideValue; /* Used to hold value to pass to sprintf if * it's a 'long long' value. */ - int whichValue; /* Indicates which of intValue, ptrValue, - * or doubleValue has the value to pass to + int whichValue; /* Indicates which of intValue, ptrValue, or + * doubleValue has the value to pass to * sprintf, according to the following * definitions: */ # define INT_VALUE 0 @@ -1972,14 +1986,15 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_Obj *resultPtr; /* Where result is stored finally. */ char staticBuf[MAX_FLOAT_SIZE + 1]; - /* A static buffer to copy the format results + /* A static buffer to copy the format results * into */ - char *dst = staticBuf; /* The buffer that sprintf writes into each + char *dst = staticBuf; /* The buffer that sprintf writes into each * time the format processes a specifier */ int dstSize = MAX_FLOAT_SIZE; /* The size of the dst buffer */ - int noPercent; /* Special case for speed: indicates there's - * no field specifier, just a string to copy.*/ + int noPercent; /* Special case for speed: indicates there's + * no field specifier, just a string to + * copy. */ int objIndex; /* Index of argument to substitute next. */ int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style * specifier has been seen. */ @@ -1999,17 +2014,17 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int useWide; /* Value to be printed is Tcl_WideInt. */ /* - * This procedure is a bit nasty. The goal is to use sprintf to - * do most of the dirty work. There are several problems: + * This procedure is a bit nasty. The goal is to use sprintf to do most + * of the dirty work. There are several problems: * 1. this procedure can't trust its arguments. * 2. we must be able to provide a large enough result area to hold - * whatever's generated. This is hard to estimate. - * 3. there's no way to move the arguments from objv to the call - * to sprintf in a reasonable way. This is particularly nasty - * because some of the arguments may be two-word values (doubles - * and wide-ints). - * So, what happens here is to scan the format string one % group - * at a time, making many individual calls to sprintf. + * whatever's generated. This is hard to estimate. + * 3. there's no way to move the arguments from objv to the call to + * sprintf in a reasonable way. This is particularly nasty because + * some of the arguments may be two-word values (doubles and + * wide-ints). + * So, what happens here is to scan the format string one % group at a + * time, making many individual calls to sprintf. */ if (objc < 2) { @@ -2033,6 +2048,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) /* * Get rid of any characters before the next field specifier. */ + if (*format != '%') { ptrValue = format; while ((*format != '%') && (format < endPtr)) { @@ -2052,10 +2068,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } /* - * Parse off a field specifier, compute how many characters - * will be needed to store the result, and substitute for - * "*" size specifiers. + * Parse off a field specifier, compute how many characters will be + * needed to store the result, and substitute for "*" size specifiers. */ + *newPtr = '%'; newPtr++; format++; @@ -2063,9 +2079,9 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) int tmp; /* - * Check for an XPG3-style %n$ specification. Note: there - * must not be a mixture of XPG3 specs and non-XPG3 specs - * in the same format string. + * Check for an XPG3-style %n$ specification. Note: there must not + * be a mixture of XPG3 specs and non-XPG3 specs in the same + * format string. */ tmp = strtoul(format, &end, 10); /* INTL: "C" locale. */ @@ -2084,13 +2100,13 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) goto xpgCheckDone; } - notXpg: + notXpg: gotSequential = 1; if (gotXpg) { goto mixedXPG; } - xpgCheckDone: + xpgCheckDone: while ((*format == '-') || (*format == '#') || (*format == '0') || (*format == ' ') || (*format == '+')) { if (*format == '-') { @@ -2098,9 +2114,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } if (*format == '0') { /* - * This will be handled by sprintf for numbers, but we - * need to do the char/string ones ourselves + * This will be handled by sprintf for numbers, but we need to + * do the char/string ones ourselves. */ + gotZero = 1; } *newPtr = *format; @@ -2129,9 +2146,8 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } if (width > 100000) { /* - * Don't allow arbitrarily large widths: could cause core - * dump when we try to allocate a zillion bytes of memory - * below. + * Don't allow arbitrarily large widths: could cause core dump + * when we try to allocate a zillion bytes of memory below. */ width = 100000; @@ -2172,10 +2188,12 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } if (*format == 'l') { useWide = 1; + /* - * Only add a 'll' modifier for integer values as it makes - * some libc's go into spasm otherwise. [Bug #702622] + * Only add a 'll' modifier for integer values as it makes some + * libc's go into spasm otherwise. [Bug #702622] */ + switch (format[1]) { case 'i': case 'd': @@ -2223,15 +2241,16 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) #if (LONG_MAX > INT_MAX) if (!useShort) { /* - * Add the 'l' for long format type because we are on an - * LP64 archtecture and we are really going to pass a long - * argument to sprintf. + * Add the 'l' for long format type because we are on an LP64 + * archtecture and we are really going to pass a long argument + * to sprintf. * - * Do not add this if we're going to pass in a short (i.e. - * if we've got an 'h' modifier already in the string); some - * libc implementations of sprintf() do not like it at all. - * [Bug 1154163] + * Do not add this if we're going to pass in a short (i.e. if + * we've got an 'h' modifier already in the string); some libc + * implementations of sprintf() do not like it at all. [Bug + * 1154163] */ + newPtr++; *newPtr = 0; newPtr[-1] = newPtr[-2]; @@ -2243,10 +2262,10 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) break; case 's': /* - * Compute the length of the string in characters and add - * any additional space required by the field width. All - * of the extra characters will be spaces, so one byte per - * character is adequate. + * Compute the length of the string in characters and add any + * additional space required by the field width. All of the extra + * characters will be spaces, so one byte per character is + * adequate. */ whichValue = STRING_VALUE; @@ -2273,7 +2292,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) case 'f': case 'g': case 'G': - if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ + if (Tcl_GetDoubleFromObj(interp, /* INTL: Tcl source. */ objv[objIndex], &doubleValue) != TCL_OK) { goto fmtError; } @@ -2301,11 +2320,11 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) format++; /* - * Make sure that there's enough space to hold the formatted - * result, then format it. + * Make sure that there's enough space to hold the formatted result, + * then format it. */ - doField: + doField: if (width > size) { size = width; } @@ -2313,7 +2332,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) Tcl_AppendToObj(resultPtr, ptrValue, size); } else { if (size > dstSize) { - if (dst != staticBuf) { + if (dst != staticBuf) { ckfree(dst); } dst = (char *) ckalloc((unsigned) (size + 1)); @@ -2368,7 +2387,7 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } } - size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; + size = Tcl_UtfAtIndex(ptrValue, stringLen) - ptrValue; if (size) { memcpy(ptr, ptrValue, (size_t) size); ptr += size; @@ -2394,24 +2413,32 @@ Tcl_FormatObjCmd(dummy, interp, objc, objv) } return TCL_OK; - mixedXPG: - Tcl_SetResult(interp, + mixedXPG: + Tcl_SetResult(interp, "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC); goto fmtError; - badIndex: + badIndex: if (gotXpg) { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "\"%n$\" argument index out of range", TCL_STATIC); } else { - Tcl_SetResult(interp, + Tcl_SetResult(interp, "not enough arguments for all format specifiers", TCL_STATIC); } - fmtError: + fmtError: if (dst != staticBuf) { ckfree(dst); } Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 31a3749..21aebe3 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1,10 +1,10 @@ -/* +/* * tclCmdIL.c -- * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * I through L. It contains only commands in the generic core - * (i.e. those that don't depend much upon UNIX facilities). + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters I through L. It + * contains only commands in the generic core (i.e. those that don't + * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1993-1997 Lucent Technologies. @@ -13,26 +13,26 @@ * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * Copyright (c) 2005 Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.77 2005/07/14 12:17:35 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.78 2005/07/17 21:17:30 dkf Exp $ */ #include "tclInt.h" #include "tclRegexp.h" /* - * During execution of the "lsort" command, structures of the following - * type are used to arrange the objects being sorted into a collection - * of linked lists. + * During execution of the "lsort" command, structures of the following type + * are used to arrange the objects being sorted into a collection of linked + * lists. */ typedef struct SortElement { Tcl_Obj *objPtr; /* Object being sorted. */ int count; /* number of same elements in list */ - struct SortElement *nextPtr; /* Next element in the list, or - * NULL for end of list. */ + struct SortElement *nextPtr; /* Next element in the list, or NULL + * for end of list. */ } SortElement; /* @@ -45,35 +45,34 @@ typedef int (*SortMemCmpFn_t) _ANSI_ARGS_((const void *, const void *, size_t)); /* - * The "lsort" command needs to pass certain information down to the - * function that compares two list elements, and the comparison function - * needs to pass success or failure information back up to the top-level - * "lsort" command. The following structure is used to pass this - * information. + * The "lsort" command needs to pass certain information down to the function + * that compares two list elements, and the comparison function needs to pass + * success or failure information back up to the top-level "lsort" command. + * The following structure is used to pass this information. */ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ - int sortMode; /* The sort mode. One of SORTMODE_* - * values defined below */ - SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with + int sortMode; /* The sort mode. One of SORTMODE_* values + * defined below */ + SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with * ASCII mode). */ - Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode - * is SORTMODE_COMMAND. Pre-initialized to - * hold base of command.*/ + Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is + * SORTMODE_COMMAND. Pre-initialized to hold + * base of command.*/ int *indexv; /* If the -index option was specified, this * holds the indexes contained in the list * supplied as an argument to that option. - * NULL if no indexes supplied, and points - * to singleIndex field when only one + * NULL if no indexes supplied, and points to + * singleIndex field when only one * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ - Tcl_Interp *interp; /* The interpreter in which the sortis - * being done. */ - int resultCode; /* Completion code for the lsort command. - * If an error occurs during the sort this - * is changed from TCL_OK to TCL_ERROR. */ + Tcl_Interp *interp; /* The interpreter in which the sort is being + * done. */ + int resultCode; /* Completion code for the lsort command. If + * an error occurs during the sort this is + * changed from TCL_OK to TCL_ERROR. */ } SortInfo; /* @@ -81,16 +80,17 @@ typedef struct SortInfo { * following values. */ -#define SORTMODE_ASCII 0 -#define SORTMODE_INTEGER 1 -#define SORTMODE_REAL 2 -#define SORTMODE_COMMAND 3 -#define SORTMODE_DICTIONARY 4 +#define SORTMODE_ASCII 0 +#define SORTMODE_INTEGER 1 +#define SORTMODE_REAL 2 +#define SORTMODE_COMMAND 3 +#define SORTMODE_DICTIONARY 4 /* - * Magic values for the index field of the SortInfo structure. - * Note that the index "end-1" will be translated to SORTIDX_END-1, etc. + * Magic values for the index field of the SortInfo structure. Note that the + * index "end-1" will be translated to SORTIDX_END-1, etc. */ + #define SORTIDX_NONE -1 /* Not indexed; use whole value. */ #define SORTIDX_END -2 /* Indexed from end. */ @@ -181,12 +181,12 @@ static Tcl_Obj * SelectObjFromSublist _ANSI_ARGS_((Tcl_Obj *firstPtr, * * Tcl_IfObjCmd -- * - * This procedure is invoked to process the "if" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "if" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "if" or the name - * to which "if" was renamed: e.g., "set z if; $z 1 {puts foo}" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "if" or the name to which + * "if" was renamed: e.g., "set z if; $z 1 {puts foo}" * * Results: * A standard Tcl result. @@ -205,17 +205,17 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int thenScriptIndex = 0; /* then script to be evaled after syntax check */ + int thenScriptIndex = 0; /* "then" script to be evaled after + * syntax check */ int i, result, value; char *clause; i = 1; while (1) { /* - * At this point in the loop, objv and objc refer to an expression - * to test, either for the main expression or an expression - * following an "elseif". The arguments after the expression must - * be "then" (optional) and a script to execute if the expression is - * true. + * At this point in the loop, objv and objc refer to an expression to + * test, either for the main expression or an expression following an + * "elseif". The arguments after the expression must be "then" + * (optional) and a script to execute if the expression is true. */ if (i >= objc) { @@ -251,8 +251,8 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) } /* - * The expression evaluated to false. Skip the command, then - * see if there is an "else" or "elseif" clause. + * The expression evaluated to false. Skip the command, then see if + * there is an "else" or "elseif" clause. */ i++; @@ -271,9 +271,9 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) } /* - * Couldn't find a "then" or "elseif" clause to execute. Check now - * for an "else" clause. We know that there's at least one more - * argument when we get here. + * Couldn't find a "then" or "elseif" clause to execute. Check now for an + * "else" clause. We know that there's at least one more argument when we + * get here. */ if (strcmp(clause, "else") == 0) { @@ -302,12 +302,12 @@ Tcl_IfObjCmd(dummy, interp, objc, objv) * * Tcl_IncrObjCmd -- * - * This procedure is invoked to process the "incr" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "incr" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "incr" or the name - * to which "incr" was renamed: e.g., "set z incr; $z i -1" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "incr" or the name to + * which "incr" was renamed: e.g., "set z incr; $z i -1" * * Results: * A standard Tcl result. @@ -342,10 +342,11 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) if (objc == 3) { /* - * Need to be a bit cautious to ensure that [expr]-like rules - * are enforced for interpretation of wide integers, despite - * the fact that the underlying API itself is a 'long' only one. + * Need to be a bit cautious to ensure that [expr]-like rules are + * enforced for interpretation of wide integers, despite the fact that + * the underlying API itself is a 'long' only one. */ + if (objv[2]->typePtr == &tclIntType) { incrAmount = objv[2]->internalRep.longValue; isWide = 0; @@ -391,7 +392,7 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) */ Tcl_SetObjResult(interp, newValuePtr); - return TCL_OK; + return TCL_OK; } /* @@ -399,8 +400,8 @@ Tcl_IncrObjCmd(dummy, interp, objc, objv) * * Tcl_InfoObjCmd -- * - * This procedure is invoked to process the "info" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "info" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -519,17 +520,17 @@ Tcl_InfoObjCmd(clientData, interp, objc, objv) * * InfoArgsCmd -- * - * Called to implement the "info args" command that returns the - * argument list for a procedure. Handles the following syntax: + * Called to implement the "info args" command that returns the argument + * list for a procedure. Handles the following syntax: * * info args procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -581,17 +582,17 @@ InfoArgsCmd(dummy, interp, objc, objv) * * InfoBodyCmd -- * - * Called to implement the "info body" command that returns the body - * for a procedure. Handles the following syntax: + * Called to implement the "info body" command that returns the body for + * a procedure. Handles the following syntax: * * info body procName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -621,21 +622,22 @@ InfoBodyCmd(dummy, interp, objc, objv) return TCL_ERROR; } - /* + /* * Here we used to return procPtr->bodyPtr, except when the body was - * bytecompiled - in that case, the return was a copy of the body's - * string rep. In order to better isolate the implementation details - * of the compiler/engine subsystem, we now always return a copy of - * the string rep. It is important to return a copy so that later - * manipulations of the object do not invalidate the internal rep. + * bytecompiled - in that case, the return was a copy of the body's string + * rep. In order to better isolate the implementation details of the + * compiler/engine subsystem, we now always return a copy of the string + * rep. It is important to return a copy so that later manipulations of + * the object do not invalidate the internal rep. */ bodyPtr = procPtr->bodyPtr; if (bodyPtr->bytes == NULL) { /* - * The string rep might not be valid if the procedure has - * never been run before. [Bug #545644] + * The string rep might not be valid if the procedure has never been + * run before. [Bug #545644] */ + (void) Tcl_GetString(bodyPtr); } resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); @@ -649,18 +651,18 @@ InfoBodyCmd(dummy, interp, objc, objv) * * InfoCmdCountCmd -- * - * Called to implement the "info cmdcount" command that returns the - * number of commands that have been executed. Handles the following - * syntax: + * Called to implement the "info cmdcount" command that returns the + * number of commands that have been executed. Handles the following + * syntax: * * info cmdcount * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -688,21 +690,21 @@ InfoCmdCountCmd(dummy, interp, objc, objv) * * InfoCommandsCmd -- * - * Called to implement the "info commands" command that returns the - * list of commands in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which commands are returned. - * Handles the following syntax: + * Called to implement the "info commands" command that returns the list + * of commands in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: * * info commands ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -727,8 +729,8 @@ InfoCommandsCmd(dummy, interp, objc, objv) int i; /* - * Get the pattern and find the "effective namespace" in which to - * list commands. + * Get the pattern and find the "effective namespace" in which to list + * commands. */ if (objc == 2) { @@ -738,10 +740,10 @@ InfoCommandsCmd(dummy, interp, objc, objv) } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no commands there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; @@ -767,20 +769,20 @@ InfoCommandsCmd(dummy, interp, objc, objv) } /* - * Scan through the effective namespace's command table and create a - * list with all commands that match the pattern. If a specific - * namespace was requested in the pattern, qualify the command names - * with the namespace name. + * Scan through the effective namespace's command table and create a list + * with all commands that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* - * Special case for when the pattern doesn't include any of - * glob's special characters. This lets us avoid scans of any - * hash tables. + * Special case for when the pattern doesn't include any of glob's + * special characters. This lets us avoid scans of any hash tables. */ + entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { if (specificNsInPattern) { @@ -824,9 +826,9 @@ InfoCommandsCmd(dummy, interp, objc, objv) } } else if (nsPtr->commandPathLength == 0 || specificNsInPattern) { /* - * The pattern is non-trivial, but either there is no explicit - * path or there is an explicit namespace in the pattern. In - * both cases, the old matching scheme is perfect. + * The pattern is non-trivial, but either there is no explicit path or + * there is an explicit namespace in the pattern. In both cases, the + * old matching scheme is perfect. */ entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); @@ -848,10 +850,10 @@ InfoCommandsCmd(dummy, interp, objc, objv) /* * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern, then add in - * all global :: commands that match the simple pattern. Of course, - * we add in only those commands that aren't hidden by a command in - * the effective namespace. + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { @@ -870,10 +872,10 @@ InfoCommandsCmd(dummy, interp, objc, objv) } } else { /* - * The pattern is non-trivial (can match more than one command - * name), there is an explicit path, and there is no explicit - * namespace in the pattern. This means that we have to - * traverse the path to discover all the commands defined. + * The pattern is non-trivial (can match more than one command name), + * there is an explicit path, and there is no explicit namespace in + * the pattern. This means that we have to traverse the path to + * discover all the commands defined. */ Tcl_HashTable addedCommandsTable; @@ -881,9 +883,9 @@ InfoCommandsCmd(dummy, interp, objc, objv) int foundGlobal = (nsPtr == globalNsPtr); /* - * We keep a hash of the objects already added to the result - * list. + * We keep a hash of the objects already added to the result list. */ + Tcl_InitObjHashTable(&addedCommandsTable); entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); @@ -932,10 +934,10 @@ InfoCommandsCmd(dummy, interp, objc, objv) /* * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern, then add in - * all global :: commands that match the simple pattern. Of course, - * we add in only those commands that aren't hidden by a command in - * the effective namespace. + * specific namespace wasn't requested in the pattern, then add in all + * global :: commands that match the simple pattern. Of course, we add + * in only those commands that aren't hidden by a command in the + * effective namespace. */ if (!foundGlobal) { @@ -968,18 +970,18 @@ InfoCommandsCmd(dummy, interp, objc, objv) * * InfoCompleteCmd -- * - * Called to implement the "info complete" command that determines - * whether a string is a complete Tcl command. Handles the following - * syntax: + * Called to implement the "info complete" command that determines + * whether a string is a complete Tcl command. Handles the following + * syntax: * * info complete command * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1010,18 +1012,17 @@ InfoCompleteCmd(dummy, interp, objc, objv) * * InfoDefaultCmd -- * - * Called to implement the "info default" command that returns the - * default value for a procedure argument. Handles the following - * syntax: + * Called to implement the "info default" command that returns the + * default value for a procedure argument. Handles the following syntax: * * info default procName arg varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1094,17 +1095,17 @@ InfoDefaultCmd(dummy, interp, objc, objv) * * InfoExistsCmd -- * - * Called to implement the "info exists" command that determines - * whether a variable exists. Handles the following syntax: + * Called to implement the "info exists" command that determines whether + * a variable exists. Handles the following syntax: * * info exists varName * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1139,18 +1140,18 @@ InfoExistsCmd(dummy, interp, objc, objv) * * InfoFunctionsCmd -- * - * Called to implement the "info functions" command that returns the - * list of math functions matching an optional pattern. Handles the - * following syntax: + * Called to implement the "info functions" command that returns the list + * of math functions matching an optional pattern. Handles the following + * syntax: * * info functions ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1187,18 +1188,18 @@ InfoFunctionsCmd(dummy, interp, objc, objv) * * InfoGlobalsCmd -- * - * Called to implement the "info globals" command that returns the list - * of global variables matching an optional pattern. Handles the - * following syntax: + * Called to implement the "info globals" command that returns the list + * of global variables matching an optional pattern. Handles the + * following syntax: * * info globals ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1224,6 +1225,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv) /* * Strip leading global-namespace qualifiers. [Bug 1057461] */ + if (pattern[0] == ':' && pattern[1] == ':') { while (*pattern == ':') { pattern++; @@ -1235,8 +1237,8 @@ InfoGlobalsCmd(dummy, interp, objc, objv) } /* - * Scan through the global :: namespace's variable table and create a - * list of all global variables that match the pattern. + * Scan through the global :: namespace's variable table and create a list + * of all global variables that match the pattern. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); @@ -1270,17 +1272,17 @@ InfoGlobalsCmd(dummy, interp, objc, objv) * * InfoHostnameCmd -- * - * Called to implement the "info hostname" command that returns the - * host name. Handles the following syntax: + * Called to implement the "info hostname" command that returns the host + * name. Handles the following syntax: * * info hostname * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1314,17 +1316,17 @@ InfoHostnameCmd(dummy, interp, objc, objv) * * InfoLevelCmd -- * - * Called to implement the "info level" command that returns - * information about the call stack. Handles the following syntax: + * Called to implement the "info level" command that returns information + * about the call stack. Handles the following syntax: * * info level ?number? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1385,18 +1387,18 @@ InfoLevelCmd(dummy, interp, objc, objv) * * InfoLibraryCmd -- * - * Called to implement the "info library" command that returns the - * library directory for the Tcl installation. Handles the following - * syntax: + * Called to implement the "info library" command that returns the + * library directory for the Tcl installation. Handles the following + * syntax: * * info library * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1430,18 +1432,18 @@ InfoLibraryCmd(dummy, interp, objc, objv) * * InfoLoadedCmd -- * - * Called to implement the "info loaded" command that returns the - * packages that have been loaded into an interpreter. Handles the - * following syntax: + * Called to implement the "info loaded" command that returns the + * packages that have been loaded into an interpreter. Handles the + * following syntax: * * info loaded ?interp? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1475,18 +1477,18 @@ InfoLoadedCmd(dummy, interp, objc, objv) * * InfoLocalsCmd -- * - * Called to implement the "info locals" command to return a list of - * local variables that match an optional pattern. Handles the - * following syntax: + * Called to implement the "info locals" command to return a list of + * local variables that match an optional pattern. Handles the following + * syntax: * * info locals ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1533,8 +1535,8 @@ InfoLocalsCmd(dummy, interp, objc, objv) * * AppendLocals -- * - * Append the local variables for the current frame to the - * specified list object. + * Append the local variables for the current frame to the specified list + * object. * * Results: * None. @@ -1613,18 +1615,18 @@ AppendLocals(interp, listPtr, pattern, includeLinks) * * InfoNameOfExecutableCmd -- * - * Called to implement the "info nameofexecutable" command that returns - * the name of the binary file running this application. Handles the - * following syntax: + * Called to implement the "info nameofexecutable" command that returns + * the name of the binary file running this application. Handles the + * following syntax: * * info nameofexecutable * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1649,18 +1651,18 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv) * * InfoPatchLevelCmd -- * - * Called to implement the "info patchlevel" command that returns the - * default value for an argument to a procedure. Handles the following - * syntax: + * Called to implement the "info patchlevel" command that returns the + * default value for an argument to a procedure. Handles the following + * syntax: * * info patchlevel * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1693,21 +1695,21 @@ InfoPatchLevelCmd(dummy, interp, objc, objv) * * InfoProcsCmd -- * - * Called to implement the "info procs" command that returns the - * list of procedures in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which commands are returned. - * Handles the following syntax: + * Called to implement the "info procs" command that returns the list of + * procedures in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which commands are returned. Handles the + * following syntax: * * info procs ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1733,8 +1735,8 @@ InfoProcsCmd(dummy, interp, objc, objv) Command *cmdPtr, *realCmdPtr; /* - * Get the pattern and find the "effective namespace" in which to - * list procs. + * Get the pattern and find the "effective namespace" in which to list + * procs. */ if (objc == 2) { @@ -1744,10 +1746,10 @@ InfoProcsCmd(dummy, interp, objc, objv) } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no commands there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no commands there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; @@ -1770,10 +1772,10 @@ InfoProcsCmd(dummy, interp, objc, objv) } /* - * Scan through the effective namespace's command table and create a - * list with all procs that match the pattern. If a specific - * namespace was requested in the pattern, qualify the command names - * with the namespace name. + * Scan through the effective namespace's command table and create a list + * with all procs that match the pattern. If a specific namespace was + * requested in the pattern, qualify the command names with the namespace + * name. */ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); @@ -1790,7 +1792,7 @@ InfoProcsCmd(dummy, interp, objc, objv) goto simpleProcOK; } } else { - simpleProcOK: + simpleProcOK: if (specificNsInPattern) { elemObjPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, @@ -1834,20 +1836,21 @@ InfoProcsCmd(dummy, interp, objc, objv) /* * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern, then add in - * all global :: procs that match the simple pattern. Of course, - * we add in only those procs that aren't hidden by a proc in - * the effective namespace. + * specific namespace wasn't requested in the pattern, then add in all + * global :: procs that match the simple pattern. Of course, we add in + * only those procs that aren't hidden by a proc in the effective + * namespace. */ #ifdef INFO_PROCS_SEARCH_GLOBAL_NS /* - * If "info procs" worked like "info commands", returning the - * commands also seen in the global namespace, then you would - * include this code. As this could break backwards compatibilty - * with 8.0-8.2, we decided not to "fix" it in 8.3, leaving the - * behavior slightly different. + * If "info procs" worked like "info commands", returning the commands + * also seen in the global namespace, then you would include this + * code. As this could break backwards compatibilty with 8.0-8.2, we + * decided not to "fix" it in 8.3, leaving the behavior slightly + * different. */ + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); while (entryPtr != NULL) { @@ -1881,21 +1884,20 @@ InfoProcsCmd(dummy, interp, objc, objv) * * InfoScriptCmd -- * - * Called to implement the "info script" command that returns the - * script file that is currently being evaluated. Handles the - * following syntax: + * Called to implement the "info script" command that returns the script + * file that is currently being evaluated. Handles the following syntax: * * info script ?newName? * * If newName is specified, it will set that as the internal name. * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. It may change the - * internal script filename. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. It may change the internal + * script filename. * *---------------------------------------------------------------------- */ @@ -1931,18 +1933,18 @@ InfoScriptCmd(dummy, interp, objc, objv) * * InfoSharedlibCmd -- * - * Called to implement the "info sharedlibextension" command that - * returns the file extension used for shared libraries. Handles the - * following syntax: + * Called to implement the "info sharedlibextension" command that returns + * the file extension used for shared libraries. Handles the following + * syntax: * * info sharedlibextension * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -1970,17 +1972,17 @@ InfoSharedlibCmd(dummy, interp, objc, objv) * * InfoTclVersionCmd -- * - * Called to implement the "info tclversion" command that returns the - * version number for this Tcl library. Handles the following syntax: + * Called to implement the "info tclversion" command that returns the + * version number for this Tcl library. Handles the following syntax: * * info tclversion * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -2013,21 +2015,21 @@ InfoTclVersionCmd(dummy, interp, objc, objv) * * InfoVarsCmd -- * - * Called to implement the "info vars" command that returns the - * list of variables in the interpreter that match an optional pattern. - * The pattern, if any, consists of an optional sequence of namespace - * names separated by "::" qualifiers, which is followed by a - * glob-style pattern that restricts which variables are returned. - * Handles the following syntax: + * Called to implement the "info vars" command that returns the list of + * variables in the interpreter that match an optional pattern. The + * pattern, if any, consists of an optional sequence of namespace names + * separated by "::" qualifiers, which is followed by a glob-style + * pattern that restricts which variables are returned. Handles the + * following syntax: * * info vars ?pattern? * * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * Returns TCL_OK if successful and TCL_ERROR if there is an error. * * Side effects: - * Returns a result in the interpreter's result object. If there is - * an error, the result is an error message. + * Returns a result in the interpreter's result object. If there is an + * error, the result is an error message. * *---------------------------------------------------------------------- */ @@ -2052,9 +2054,9 @@ InfoVarsCmd(dummy, interp, objc, objv) int specificNsInPattern = 0; /* Init. to avoid compiler warning. */ /* - * Get the pattern and find the "effective namespace" in which to - * list variables. We only use this effective namespace if there's - * no active Tcl procedure frame. + * Get the pattern and find the "effective namespace" in which to list + * variables. We only use this effective namespace if there's no active + * Tcl procedure frame. */ if (objc == 2) { @@ -2064,10 +2066,10 @@ InfoVarsCmd(dummy, interp, objc, objv) } else if (objc == 3) { /* * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an - * error was found while parsing the pattern, return it. Otherwise, - * if the namespace wasn't found, just leave nsPtr NULL: we will - * return an empty list since no variables there can be found. + * pattern (no namespace qualifiers or ::'s) at the end. If an error + * was found while parsing the pattern, return it. Otherwise, if the + * namespace wasn't found, just leave nsPtr NULL: we will return an + * empty list since no variables there can be found. */ Namespace *dummy1NsPtr, *dummy2NsPtr; @@ -2099,16 +2101,15 @@ InfoVarsCmd(dummy, interp, objc, objv) || !(iPtr->varFramePtr->isProcCallFrame & FRAME_IS_PROC) || specificNsInPattern) { /* - * There is no frame pointer, the frame pointer was pushed only - * to activate a namespace, or we are in a procedure call frame - * but a specific namespace was specified. Create a list containing - * only the variables in the effective namespace's variable table. + * There is no frame pointer, the frame pointer was pushed only to + * activate a namespace, or we are in a procedure call frame but a + * specific namespace was specified. Create a list containing only the + * variables in the effective namespace's variable table. */ if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { /* - * If we can just do hash lookups, that simplifies things - * a lot. + * If we can just do hash lookups, that simplifies things a lot. */ entryPtr = Tcl_FindHashEntry(&nsPtr->varTable, simplePattern); @@ -2163,12 +2164,11 @@ InfoVarsCmd(dummy, interp, objc, objv) } /* - * If the effective namespace isn't the global :: - * namespace, and a specific namespace wasn't requested in - * the pattern (i.e., the pattern only specifies variable - * names), then add in all global :: variables that match - * the simple pattern. Of course, add in only those - * variables that aren't hidden by a variable in the + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern (i.e., the + * pattern only specifies variable names), then add in all global + * :: variables that match the simple pattern. Of course, add in + * only those variables that aren't hidden by a variable in the * effective namespace. */ @@ -2206,8 +2206,8 @@ InfoVarsCmd(dummy, interp, objc, objv) * * Tcl_JoinObjCmd -- * - * This procedure is invoked to process the "join" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "join" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -2242,8 +2242,8 @@ Tcl_JoinObjCmd(dummy, interp, objc, objv) } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[1], &listLen, &elemPtrs); @@ -2313,9 +2313,10 @@ Tcl_LassignObjCmd(dummy, interp, objc, objv) for (i=0 ; i+2 objc-2) { /* - * OK, there were left-overs. Make a list of them and slap - * that back in the interpreter result. + * OK, there were left-overs. Make a list of them and slap that back + * in the interpreter result. */ + Tcl_SetObjResult(interp, Tcl_NewListObj(listObjc - objc + 2, listObjv + objc - 2)); } @@ -2406,10 +2408,10 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv) } /* - * If objc==3, then objv[2] may be either a single index or a list - * of indices: go to TclLindexList to determine which. - * If objc>=4, or objc==2, then objv[2 .. objc-2] are all single - * indices and processed as such in TclLindexFlat. + * If objc==3, then objv[2] may be either a single index or a list of + * indices: go to TclLindexList to determine which. If objc>=4, or + * objc==2, then objv[2 .. objc-2] are all single indices and processed as + * such in TclLindexFlat. */ if (objc == 3) { @@ -2419,7 +2421,7 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv) } /* - * Set the interpreter's object result to the last element extracted + * Set the interpreter's object result to the last element extracted. */ if (elemPtr == NULL) { @@ -2439,20 +2441,20 @@ Tcl_LindexObjCmd(dummy, interp, objc, objv) * This procedure handles the 'lindex' command when objc==3. * * Results: - * Returns a pointer to the object extracted, or NULL if an - * error occurred. + * Returns a pointer to the object extracted, or NULL if an error + * occurred. * * Side effects: * None. * * Notes: - * If objv[1] can be parsed as a list, TclLindexList handles - * extraction of the desired element locally. Otherwise, it - * invokes TclLindexFlat to treat objv[1] as a scalar. + * If objv[1] can be parsed as a list, TclLindexList handles extraction + * of the desired element locally. Otherwise, it invokes TclLindexFlat + * to treat objv[1] as a scalar. * - * The reference count of the returned object includes one - * reference corresponding to the pointer returned. Thus, the - * calling code will usually do something like: + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: * Tcl_SetObjResult(interp, result); * Tcl_DecrRefCount(result); * @@ -2468,48 +2470,48 @@ TclLindexList(interp, listPtr, argPtr) Tcl_Obj **elemPtrs; /* Elements of the list being manipulated. */ int listLen; /* Length of the list being manipulated. */ - int index; /* Index into the list */ - int result; /* Result returned from a Tcl library call */ - int i; /* Current index number */ - Tcl_Obj **indices; /* Array of list indices */ - int indexCount; /* Size of the array of list indices */ - Tcl_Obj *oldListPtr; /* Temp location to preserve the list - * pointer when replacing it with a sublist */ + int index; /* Index into the list. */ + int result; /* Result returned from a Tcl library call. */ + int i; /* Current index number. */ + Tcl_Obj **indices; /* Array of list indices. */ + int indexCount; /* Size of the array of list indices. */ + Tcl_Obj *oldListPtr; /* Temp location to preserve the list pointer + * when replacing it with a sublist. */ /* - * Determine whether argPtr designates a list or a single index. - * We have to be careful about the order of the checks to avoid - * repeated shimmering; see TIP#22 and TIP#33 for the details. + * Determine whether argPtr designates a list or a single index. We have + * to be careful about the order of the checks to avoid repeated + * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + if (argPtr->typePtr != &tclListType && TclGetIntForIndex(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); - } + if (Tcl_ListObjGetElements(NULL, argPtr, &indexCount, &indices) != TCL_OK){ /* * argPtr designates something that is neither an index nor a * well-formed list. Report the error via TclLindexFlat. */ - return TclLindexFlat( interp, listPtr, 1, &argPtr ); + return TclLindexFlat(interp, listPtr, 1, &argPtr); } /* - * Record the reference to the list that we are maintaining in - * the activation record. + * Record the reference to the list that we are maintaining in the + * activation record. */ Tcl_IncrRefCount(listPtr); /* - * argPtr designates a list, and the 'else if' above has parsed it - * into indexCount and indices. + * argPtr designates a list, and the 'else if' above has parsed it into + * indexCount and indices. */ for (i=0 ; itypePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); + &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; @@ -2572,23 +2575,24 @@ TclLindexList(interp, listPtr, argPtr) Tcl_DecrRefCount(oldListPtr); /* - * The work we did above may have caused the internal rep - * of *argPtr to change to something else. Get it back. + * The work we did above may have caused the internal rep of *argPtr + * to change to something else. Get it back. */ result = Tcl_ListObjGetElements(interp, argPtr, &indexCount, &indices); if (result != TCL_OK) { - /* + /* * This can't happen unless some extension corrupted a Tcl_Obj. */ + Tcl_DecrRefCount(listPtr); return NULL; } } /* - * Return the last object extracted. Its reference count will include - * the reference being returned. + * Return the last object extracted. Its reference count will include the + * reference being returned. */ return listPtr; @@ -2599,8 +2603,8 @@ TclLindexList(interp, listPtr, argPtr) * * TclLindexFlat -- * - * This procedure handles the 'lindex' command, given that the - * arguments to the command are known to be a flat list. + * This procedure handles the 'lindex' command, given that the arguments + * to the command are known to be a flat list. * * Results: * Returns a standard Tcl result. @@ -2609,11 +2613,10 @@ TclLindexList(interp, listPtr, argPtr) * None. * * Notes: - * This procedure is called from either tclExecute.c or - * Tcl_LindexObjCmd whenever either is presented with objc==2 or - * objc>=4. It is also called from TclLindexList for the objc==3 - * case once it is determined that objv[2] cannot be parsed as a - * list. + * This procedure is called from either tclExecute.c or Tcl_LindexObjCmd + * whenever either is presented with objc==2 or objc>=4. It is also + * called from TclLindexList for the objc==3 case once it is determined + * that objv[2] cannot be parsed as a list. * *---------------------------------------------------------------------- */ @@ -2625,23 +2628,22 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) int indexCount; /* Count of indices */ Tcl_Obj *CONST indexArray[]; /* Array of pointers to Tcl objects - * representing the indices in the - * list */ + * representing the indices in the list. */ { - int i; /* Current list index */ - int result; /* Result of Tcl library calls */ - int listLen; /* Length of the current list being - * processed */ - Tcl_Obj** elemPtrs; /* Array of pointers to the elements - * of the current list */ - int index; /* Parsed version of the current element - * of indexArray */ - Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that - * its ref count can be decremented. */ + int i; /* Current list index. */ + int result; /* Result of Tcl library calls. */ + int listLen; /* Length of the current list being + * processed. */ + Tcl_Obj** elemPtrs; /* Array of pointers to the elements of the + * current list. */ + int index; /* Parsed version of the current element of + * indexArray. */ + Tcl_Obj* oldListPtr; /* Temporary to hold listPtr so that its ref + * count can be decremented. */ /* - * Record the reference to the 'listPtr' object that we are - * maintaining in the C activation record. + * Record the reference to the 'listPtr' object that we are maintaining in + * the C activation record. */ Tcl_IncrRefCount(listPtr); @@ -2658,14 +2660,14 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) } /* - * Get the index from objv[i] + * Get the index from objv[i]. */ result = TclGetIntForIndex(interp, indexArray[i], /*endValue*/ listLen-1, &index); if (result != TCL_OK) { /* - * Index could not be parsed + * Index could not be parsed. */ Tcl_DecrRefCount(listPtr); @@ -2673,7 +2675,7 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) } else if (index<0 || index>=listLen) { /* - * Index is out of range + * Index is out of range. */ Tcl_DecrRefCount(listPtr); @@ -2683,14 +2685,14 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) } /* - * Make sure listPtr still refers to a list object. - * It might have been converted to something else above - * if objv[1] overlaps with one of the other parameters. + * Make sure listPtr still refers to a list object. It might have + * been converted to something else above if objv[1] overlaps with one + * of the other parameters. */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, - &elemPtrs); + &elemPtrs); if (result != TCL_OK) { Tcl_DecrRefCount(listPtr); return NULL; @@ -2698,7 +2700,7 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) } /* - * Extract the pointer to the appropriate element + * Extract the pointer to the appropriate element. */ oldListPtr = listPtr; @@ -2708,7 +2710,6 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) } return listPtr; - } /* @@ -2720,8 +2721,8 @@ TclLindexFlat(interp, listPtr, indexCount, indexArray) * command. See the user documentation for details on what it does. * * Results: - * A new Tcl list object formed by inserting zero or more elements - * into a list. + * A new Tcl list object formed by inserting zero or more elements into a + * list. * * Side effects: * See the user documentation. @@ -2765,8 +2766,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) } /* - * If the list object is unshared we can modify it directly. Otherwise - * we create a copy to modify: this is "copy on write". + * If the list object is unshared we can modify it directly. Otherwise we + * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; @@ -2780,6 +2781,7 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) /* * Special case: insert one element at the end of the list. */ + result = Tcl_ListObjAppendElement(interp, listPtr, objv[3]); } else if (objc > 3) { result = Tcl_ListObjReplace(interp, listPtr, index, 0, @@ -2805,8 +2807,8 @@ Tcl_LinsertObjCmd(dummy, interp, objc, objv) * * Tcl_ListObjCmd -- * - * This procedure is invoked to process the "list" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "list" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -2875,7 +2877,7 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv) /* * Set the interpreter's object result to an integer object holding the - * length. + * length. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); @@ -2887,8 +2889,8 @@ Tcl_LlengthObjCmd(dummy, interp, objc, objv) * * Tcl_LrangeObjCmd -- * - * This procedure is invoked to process the "lrange" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lrange" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -2917,8 +2919,8 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ listPtr = objv[1]; @@ -2956,7 +2958,7 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) /* * Make sure listPtr still refers to a list object. It might have been * converted to an int above if the argument objects were shared. - */ + */ if (listPtr->typePtr != &tclListType) { result = Tcl_ListObjGetElements(interp, listPtr, &listLen, @@ -2967,8 +2969,8 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) } /* - * Extract a range of fields. We modify the interpreter's result object - * to be a list object containing the specified elements. + * Extract a range of fields. We modify the interpreter's result object to + * be a list object containing the specified elements. */ numElems = (last - first + 1); @@ -2981,8 +2983,8 @@ Tcl_LrangeObjCmd(notUsed, interp, objc, objv) * * Tcl_LrepeatObjCmd -- * - * This procedure is invoked to process the "lrepeat" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lrepeat" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -3004,8 +3006,8 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) int elementCount, i, result; Tcl_Obj *listPtr, **dataArray; List *listRepPtr; - - /* + + /* * Check arguments for legality: * lrepeat posInt value ?value ...? */ @@ -3025,8 +3027,7 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) } /* - * Skip forward to the interesting arguments now we've finished - * parsing. + * Skip forward to the interesting arguments now we've finished parsing. */ objc -= 2; @@ -3043,10 +3044,10 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) dataArray = &listRepPtr->elements; /* - * Set the elements. Note that we handle the common degenerate - * case of a single value being repeated separately to permit the - * compiler as much room as possible to optimize a loop that might - * be run a very large number of times. + * Set the elements. Note that we handle the common degenerate case of a + * single value being repeated separately to permit the compiler as much + * room as possible to optimize a loop that might be run a very large + * number of times. */ if (objc == 1) { @@ -3076,12 +3077,12 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) * * Tcl_LreplaceObjCmd -- * - * This object-based procedure is invoked to process the "lreplace" - * Tcl command. See the user documentation for details on what it does. + * This object-based procedure is invoked to process the "lreplace" Tcl + * command. See the user documentation for details on what it does. * * Results: - * A new Tcl list object formed by replacing zero or more elements of - * a list. + * A new Tcl list object formed by replacing zero or more elements of a + * list. * * Side effects: * See the user documentation. @@ -3113,8 +3114,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) /* * Get the first and last indexes. "end" is interpreted to be the index - * for the last element, such that using it will cause that element to - * be included for deletion. + * for the last element, such that using it will cause that element to be + * included for deletion. */ result = TclGetIntForIndex(interp, objv[2], /*end*/ (listLen - 1), &first); @@ -3153,8 +3154,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) } /* - * If the list object is unshared we can modify it directly, otherwise - * we create a copy to modify: this is "copy on write". + * If the list object is unshared we can modify it directly, otherwise we + * create a copy to modify: this is "copy on write". */ listPtr = objv[1]; @@ -3165,7 +3166,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) } if (objc > 4) { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, - (objc-4), &(objv[4])); + (objc-4), &(objv[4])); } else { result = Tcl_ListObjReplace(interp, listPtr, first, numToDelete, 0, NULL); @@ -3178,7 +3179,7 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) } /* - * Set the interpreter's object result. + * Set the interpreter's object result. */ Tcl_SetObjResult(interp, listPtr); @@ -3190,8 +3191,8 @@ Tcl_LreplaceObjCmd(dummy, interp, objc, objv) * * Tcl_LsearchObjCmd -- * - * This procedure is invoked to process the "lsearch" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lsearch" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -3211,8 +3212,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) { char *bytes, *patternBytes; int i, match, mode, index, result, listc, length, elemLen; - int dataType, isIncreasing, lower, upper, patInt, objInt; - int offset, allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; + int dataType, isIncreasing, lower, upper, patInt, objInt, offset; + int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; @@ -3324,10 +3325,10 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) break; case LSEARCH_START: /* -start */ /* - * If there was a previous -start option, release its saved - * index because it will either be replaced or there will be - * an error. + * If there was a previous -start option, release its saved index + * because it will either be replaced or there will be an error. */ + if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } @@ -3341,12 +3342,12 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) i++; if (objv[i] == objv[objc - 2]) { /* - * Take copy to prevent shimmering problems. Note - * that it does not matter if the index obj is also a - * component of the list being searched. We only need - * to copy where the list and the index are - * one-and-the-same. + * Take copy to prevent shimmering problems. Note that it + * does not matter if the index obj is also a component of the + * list being searched. We only need to copy where the list + * and the index are one-and-the-same. */ + startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; @@ -3371,8 +3372,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) /* * Store the extracted indices for processing by sublist - * extraction. Note that we don't do this using objects - * because that has shimmering problems. + * extraction. Note that we don't do this using objects because + * that has shimmering problems. */ i++; @@ -3396,16 +3397,16 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } /* - * Fill the array by parsing each index. We don't know - * whether their scale is sensible yet, but we at least - * perform the syntactic check here. + * Fill the array by parsing each index. We don't know whether + * their scale is sensible yet, but we at least perform the + * syntactic check here. */ for (j=0 ; j 1) { ckfree((char *) sortInfo.indexv); } @@ -3440,6 +3441,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. */ + regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | TCL_REG_NOSUB | (noCase ? TCL_REG_NOCASE : 0)); @@ -3455,8 +3457,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } /* - * Make sure the list argument is a list object and get its length and - * a pointer to its array of element pointers. + * Make sure the list argument is a list object and get its length and a + * pointer to its array of element pointers. */ result = Tcl_ListObjGetElements(interp, objv[objc - 2], &listc, &listv); @@ -3473,6 +3475,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) /* * Get the user-specified start offset. */ + if (startPtr) { result = TclGetIntForIndex(interp, startPtr, listc-1, &offset); Tcl_DecrRefCount(startPtr); @@ -3522,21 +3525,21 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } /* - * Set default index value to -1, indicating failure; if we find the - * item in the course of our search, index will be set to the correct - * value. + * Set default index value to -1, indicating failure; if we find the item + * in the course of our search, index will be set to the correct value. */ + index = -1; match = 0; if ((enum modes) mode == SORTED && !allMatches && !negatedMatch) { /* - * If the data is sorted, we can do a more intelligent search. - * Note that there is no point in being smart when -all was - * specified; in that case, we have to look at all items anyway, - * and there is no sense in doing this when the match sense is - * inverted. + * If the data is sorted, we can do a more intelligent search. Note + * that there is no point in being smart when -all was specified; in + * that case, we have to look at all items anyway, and there is no + * sense in doing this when the match sense is inverted. */ + lower = offset - 1; upper = listc; while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { @@ -3592,17 +3595,19 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } if (match == 0) { /* - * Normally, binary search is written to stop when it - * finds a match. If there are duplicates of an element in - * the list, our first match might not be the first occurance. + * Normally, binary search is written to stop when it finds a + * match. If there are duplicates of an element in the list, + * our first match might not be the first occurance. * Consider: 0 0 0 1 1 1 2 2 2 - * To maintain consistancy with standard lsearch semantics, - * we must find the leftmost occurance of the pattern in the - * list. Thus we don't just stop searching here. This + * + * To maintain consistancy with standard lsearch semantics, we + * must find the leftmost occurance of the pattern in the + * list. Thus we don't just stop searching here. This * variation means that a search always makes log n - * comparisons (normal binary search might "get lucky" with - * an early comparison). + * comparisons (normal binary search might "get lucky" with an + * early comparison). */ + index = i; upper = i; } else if (match > 0) { @@ -3627,6 +3632,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * - our matching sense is negated * - we're building a list of all matched items */ + if (allMatches) { listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL); } @@ -3650,9 +3656,10 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) bytes = Tcl_GetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { /* - * This split allows for more optimal - * compilation of memcmp + * This split allows for more optimal compilation of + * memcmp/ */ + if (noCase) { match = (strcasecmp(bytes, patternBytes) == 0); } else { @@ -3714,9 +3721,11 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } break; } + /* * Invert match condition for -not */ + if (negatedMatch) { match = !match; } @@ -3730,6 +3739,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) /* * Note that these appends are not expected to fail. */ + if (returnSubindices) { itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { @@ -3753,6 +3763,7 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) /* * Return everything or a single value. */ + if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { @@ -3769,16 +3780,19 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) } } else if (index < 0) { /* - * Is this superfluous? The result should be a blank object - * by default... + * Is this superfluous? The result should be a blank object by + * default... */ + Tcl_SetObjResult(interp, Tcl_NewObj()); } else { Tcl_SetObjResult(interp, listv[index]); } + /* * Cleanup the index list array. */ + if (sortInfo.indexc > 1) { ckfree((char *) sortInfo.indexv); } @@ -3790,8 +3804,8 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) * * Tcl_LsetObjCmd -- * - * This procedure is invoked to process the "lset" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lset" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -3803,66 +3817,71 @@ Tcl_LsearchObjCmd(clientData, interp, objc, objv) */ int -Tcl_LsetObjCmd( clientData, interp, objc, objv ) +Tcl_LsetObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument values. */ { - Tcl_Obj* listPtr; /* Pointer to the list being altered. */ - Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable */ + Tcl_Obj* finalValuePtr; /* Value finally assigned to the variable. */ - /* Check parameter count */ + /* + * Check parameter count. + */ - if ( objc < 3 ) { - Tcl_WrongNumArgs( interp, 1, objv, "listVar index ?index...? value" ); + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "listVar index ?index...? value"); return TCL_ERROR; } - /* Look up the list variable's value */ + /* + * Look up the list variable's value. + */ - listPtr = Tcl_ObjGetVar2( interp, objv[ 1 ], (Tcl_Obj*) NULL, - TCL_LEAVE_ERR_MSG ); - if ( listPtr == NULL ) { + listPtr = Tcl_ObjGetVar2(interp, objv[1], (Tcl_Obj *) NULL, + TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { return TCL_ERROR; } - /* - * Substitute the value in the value. Return either the value or - * else an unshared copy of it. + /* + * Substitute the value in the value. Return either the value or else an + * unshared copy of it. */ - if ( objc == 4 ) { - finalValuePtr = TclLsetList( interp, listPtr, - objv[ 2 ], objv[ 3 ] ); + if (objc == 4) { + finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { - finalValuePtr = TclLsetFlat( interp, listPtr, - objc-3, objv+2, objv[ objc-1 ] ); + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); } /* * If substitution has failed, bail out. */ - if ( finalValuePtr == NULL ) { + if (finalValuePtr == NULL) { return TCL_ERROR; } - /* Finally, update the variable so that traces fire. */ + /* + * Finally, update the variable so that traces fire. + */ - listPtr = Tcl_ObjSetVar2( interp, objv[1], NULL, finalValuePtr, - TCL_LEAVE_ERR_MSG ); - Tcl_DecrRefCount( finalValuePtr ); - if ( listPtr == NULL ) { + listPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, finalValuePtr, + TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(finalValuePtr); + if (listPtr == NULL) { return TCL_ERROR; } - /* Return the new value of the variable as the interpreter result. */ + /* + * Return the new value of the variable as the interpreter result. + */ - Tcl_SetObjResult( interp, listPtr ); + Tcl_SetObjResult(interp, listPtr); return TCL_OK; - } /* @@ -3870,8 +3889,8 @@ Tcl_LsetObjCmd( clientData, interp, objc, objv ) * * Tcl_LsortObjCmd -- * - * This procedure is invoked to process the "lsort" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "lsort" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -3894,10 +3913,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) int length; Tcl_Obj *cmdPtr, **listObjPtrs; SortElement *elementArray; - SortElement *elementPtr; - SortInfo sortInfo; /* Information about this sort that - * needs to be passed to the - * comparison function */ + SortElement *elementPtr; + SortInfo sortInfo; /* Information about this sort that needs to + * be passed to the comparison function. */ static CONST char *switches[] = { "-ascii", "-command", "-decreasing", "-dictionary", "-increasing", "-index", "-indices", "-integer", "-nocase", "-real", "-unique", @@ -3929,8 +3947,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) unique = 0; indices = 0; for (i = 1; i < objc-1; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) - != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } switch ((enum Lsort_Switches) index) { @@ -3972,11 +3990,13 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) "followed by list index", NULL); return TCL_ERROR; } + /* * Take copy to prevent shimmering problems. */ - if (Tcl_ListObjGetElements(interp, objv[i+1], - &sortInfo.indexc, &indices) != TCL_OK) { + + if (Tcl_ListObjGetElements(interp, objv[i+1], &sortInfo.indexc, + &indices) != TCL_OK) { return TCL_ERROR; } switch (sortInfo.indexc) { @@ -3992,16 +4012,16 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) } /* - * Fill the array by parsing each index. We don't know - * whether their scale is sensible yet, but we at least - * perform the syntactic check here. + * Fill the array by parsing each index. We don't know whether + * their scale is sensible yet, but we at least perform the + * syntactic check here. */ for (j=0 ; j 1) { ckfree((char *) sortInfo.indexv); } @@ -4036,9 +4056,8 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) if (sortInfo.sortMode == SORTMODE_COMMAND) { /* - * The existing command is a list. We want to flatten it, append - * two dummy arguments on the end, and replace these arguments - * later. + * The existing command is a list. We want to flatten it, append two + * dummy arguments on the end, and replace these arguments later. */ Tcl_Obj *newCommandPtr = Tcl_DuplicateObj(cmdPtr); @@ -4113,7 +4132,7 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) sortInfo.compareCmdPtr = NULL; } if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + ckfree((char *) sortInfo.indexv); } return sortInfo.resultCode; } @@ -4123,29 +4142,27 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv) * * MergeSort - * - * This procedure sorts a linked list of SortElement structures - * use the merge-sort algorithm. + * This procedure sorts a linked list of SortElement structures use the + * merge-sort algorithm. * * Results: - * A pointer to the head of the list after sorting is returned. + * A pointer to the head of the list after sorting is returned. * * Side effects: - * None, unless a user-defined comparison command does something - * weird. + * None, unless a user-defined comparison command does something weird. * *---------------------------------------------------------------------- */ static SortElement * MergeSort(headPtr, infoPtr) - SortElement *headPtr; /* First element on the list */ - SortInfo *infoPtr; /* Information needed by the - * comparison operator */ + SortElement *headPtr; /* First element on the list. */ + SortInfo *infoPtr; /* Information needed by the + * comparison operator. */ { /* - * The subList array below holds pointers to temporary lists built - * during the merge sort. Element i of the array holds a list of - * length 2**i. + * The subList array below holds pointers to temporary lists built during + * the merge sort. Element i of the array holds a list of length 2**i. */ # define NUM_LISTS 30 @@ -4153,14 +4170,14 @@ MergeSort(headPtr, infoPtr) SortElement *elementPtr; int i; - for(i = 0; i < NUM_LISTS; i++){ + for (i=0 ; inextPtr; elementPtr->nextPtr = 0; - for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){ + for (i=0 ; iresultCode != TCL_OK) { /* - * Once an error has occurred, skip any future comparisons so - * as to preserve the error message in sortInterp->result. + * Once an error has occurred, skip any future comparisons so as to + * preserve the error message in sortInterp->result. */ + return order; } @@ -4317,9 +4333,8 @@ SortCompare(objPtr1, objPtr2, infoPtr) } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - if ((Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) - || (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) - != TCL_OK)) { + if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK + || Tcl_GetDoubleFromObj(infoPtr->interp,objPtr2,&b) != TCL_OK){ infoPtr->resultCode = TCL_ERROR; return order; } @@ -4336,8 +4351,8 @@ SortCompare(objPtr1, objPtr2, infoPtr) paramObjv[1] = objPtr2; /* - * We made space in the command list for the two things to - * compare. Replace them and evaluate the result. + * We made space in the command list for the two things to compare. + * Replace them and evaluate the result. */ Tcl_ListObjLength(infoPtr->interp, infoPtr->compareCmdPtr, &objc); @@ -4378,18 +4393,18 @@ SortCompare(objPtr1, objPtr2, infoPtr) * * DictionaryCompare * - * This function compares two strings as if they were being used in - * an index or card catalog. The case of alphabetic characters is - * ignored, except to break ties. Thus "B" comes before "b" but - * after "a". Also, integers embedded in the strings compare in - * numerical order. In other words, "x10y" comes after "x9y", not - * before it as it would when using strcmp(). + * This function compares two strings as if they were being used in an + * index or card catalog. The case of alphabetic characters is ignored, + * except to break ties. Thus "B" comes before "b" but after "a". Also, + * integers embedded in the strings compare in numerical order. In other + * words, "x10y" comes after "x9y", not * before it as it would when + * using strcmp(). * * Results: - * A negative result means that the first element comes before the - * second, and a positive result means that the second element - * should come first. A result of zero means the two elements - * are equal and it doesn't matter which comes first. + * A negative result means that the first element comes before the + * second, and a positive result means that the second element should + * come first. A result of zero means the two elements are equal and it + * doesn't matter which comes first. * * Side effects: * None. @@ -4399,21 +4414,20 @@ SortCompare(objPtr1, objPtr2, infoPtr) static int DictionaryCompare(left, right) - char *left, *right; /* The strings to compare */ + char *left, *right; /* The strings to compare. */ { Tcl_UniChar uniLeft, uniRight, uniLeftLower, uniRightLower; int diff, zeros; int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) /* INTL: digit */ - && isdigit(UCHAR(*left))) { /* INTL: digit */ + if (isdigit(UCHAR(*right)) /* INTL: digit */ + && isdigit(UCHAR(*left))) { /* INTL: digit */ /* - * There are decimal numbers embedded in the two - * strings. Compare them as numbers, rather than - * strings. If one number has more leading zeros than - * the other, the number with more leading zeros sorts - * later, but only as a secondary choice. + * There are decimal numbers embedded in the two strings. Compare + * them as numbers, rather than strings. If one number has more + * leading zeros than the other, the number with more leading + * zeros sorts later, but only as a secondary choice. */ zeros = 0; @@ -4430,10 +4444,10 @@ DictionaryCompare(left, right) } /* - * The code below compares the numbers in the two - * strings without ever converting them to integers. It - * does this by first comparing the lengths of the - * numbers and then comparing the digit values. + * The code below compares the numbers in the two strings without + * ever converting them to integers. It does this by first + * comparing the lengths of the numbers and then comparing the + * digit values. */ diff = 0; @@ -4443,13 +4457,13 @@ DictionaryCompare(left, right) } right++; left++; - if (!isdigit(UCHAR(*right))) { /* INTL: digit */ - if (isdigit(UCHAR(*left))) { /* INTL: digit */ + if (!isdigit(UCHAR(*right))) { /* INTL: digit */ + if (isdigit(UCHAR(*left))) { /* INTL: digit */ return 1; } else { /* - * The two numbers have the same length. See - * if their values are different. + * The two numbers have the same length. See if their + * values are different. */ if (diff != 0) { @@ -4457,7 +4471,7 @@ DictionaryCompare(left, right) } break; } - } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ + } else if (!isdigit(UCHAR(*left))) { /* INTL: digit */ return -1; } } @@ -4473,12 +4487,14 @@ DictionaryCompare(left, right) if ((*left != '\0') && (*right != '\0')) { left += Tcl_UtfToUniChar(left, &uniLeft); right += Tcl_UtfToUniChar(right, &uniRight); + /* * Convert both chars to lower for the comparison, because * dictionary sorts are case insensitve. Covert to lower, not * upper, so chars between Z and a will sort before A (where most * other interesting punctuations occur) */ + uniLeftLower = Tcl_UniCharToLower(uniLeft); uniRightLower = Tcl_UniCharToLower(uniRight); } else { @@ -4490,8 +4506,7 @@ DictionaryCompare(left, right) if (diff) { return diff; } else if (secondaryDiff == 0) { - if (Tcl_UniCharIsUpper(uniLeft) && - Tcl_UniCharIsLower(uniRight)) { + if (Tcl_UniCharIsUpper(uniLeft) && Tcl_UniCharIsLower(uniRight)) { secondaryDiff = -1; } else if (Tcl_UniCharIsUpper(uniRight) && Tcl_UniCharIsLower(uniLeft)) { @@ -4510,20 +4525,20 @@ DictionaryCompare(left, right) * * SelectObjFromSublist -- * - * This procedure is invoked from lsearch and SortCompare. It is - * used for implementing the -index option, for the lsort and - * lsearch commands. + * This procedure is invoked from lsearch and SortCompare. It is used + * for implementing the -index option, for the lsort and lsearch + * commands. * * Results: - * Returns NULL if a failure occurs, and sets the result in the - * infoPtr. Otherwise returns the Tcl_Obj* to the item. + * Returns NULL if a failure occurs, and sets the result in the infoPtr. + * Otherwise returns the Tcl_Obj* to the item. * * Side effects: - * None. + * None. * * Note: - * No reference counting is done, as the result is only used - * internally and never passed directly to user code. + * No reference counting is done, as the result is only used internally + * and never passed directly to user code. * *---------------------------------------------------------------------- */ @@ -4546,8 +4561,8 @@ SelectObjFromSublist(objPtr, infoPtr) } /* - * Iterate over the indices, traversing through the nested - * sublists as we go. + * Iterate over the indices, traversing through the nested sublists as we + * go. */ for (i=0 ; iindexc ; i++) { @@ -4560,12 +4575,15 @@ SelectObjFromSublist(objPtr, infoPtr) return NULL; } index = infoPtr->indexv[i]; + /* * Adjust for end-based indexing. */ + if (index < SORTIDX_NONE) { index += listLen + 1; } + if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; @@ -4584,3 +4602,11 @@ SelectObjFromSublist(objPtr, infoPtr) } return objPtr; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 7d0f80f..094dcac 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -1,10 +1,10 @@ -/* +/* * tclCmdMZ.c -- * - * This file contains the top-level command routines for most of - * the Tcl built-in commands whose names begin with the letters - * M to Z. It contains only commands in the generic core (i.e. - * those that don't depend much upon UNIX facilities). + * This file contains the top-level command routines for most of the Tcl + * built-in commands whose names begin with the letters M to Z. It + * contains only commands in the generic core (i.e. those that don't + * depend much upon UNIX facilities). * * Copyright (c) 1987-1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. @@ -12,10 +12,10 @@ * Copyright (c) 2002 ActiveState Corporation. * Copyright (c) 2003 Donal K. Fellows. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdMZ.c,v 1.126 2005/06/20 07:49:11 mdejong Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.127 2005/07/17 21:17:37 dkf Exp $ */ #include "tclInt.h" @@ -26,8 +26,8 @@ * * Tcl_PwdObjCmd -- * - * This procedure is invoked to process the "pwd" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "pwd" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -67,8 +67,8 @@ Tcl_PwdObjCmd(dummy, interp, objc, objv) * * Tcl_RegexpObjCmd -- * - * This procedure is invoked to process the "regexp" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "regexp" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -110,7 +110,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) offset = 0; all = 0; doinline = 0; - + for (i = 1; i < objc; i++) { char *name; int index; @@ -124,77 +124,69 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) goto optionError; } switch ((enum options) index) { - case REGEXP_ALL: { - all = 1; - break; - } - case REGEXP_INDICES: { - indices = 1; - break; - } - case REGEXP_INLINE: { - doinline = 1; - break; - } - case REGEXP_NOCASE: { - cflags |= TCL_REG_NOCASE; - break; - } - case REGEXP_ABOUT: { - about = 1; - break; - } - case REGEXP_EXPANDED: { - cflags |= TCL_REG_EXPANDED; - break; - } - case REGEXP_LINE: { - cflags |= TCL_REG_NEWLINE; - break; - } - case REGEXP_LINESTOP: { - cflags |= TCL_REG_NLSTOP; - break; - } - case REGEXP_LINEANCHOR: { - cflags |= TCL_REG_NLANCH; - break; + case REGEXP_ALL: + all = 1; + break; + case REGEXP_INDICES: + indices = 1; + break; + case REGEXP_INLINE: + doinline = 1; + break; + case REGEXP_NOCASE: + cflags |= TCL_REG_NOCASE; + break; + case REGEXP_ABOUT: + about = 1; + break; + case REGEXP_EXPANDED: + cflags |= TCL_REG_EXPANDED; + break; + case REGEXP_LINE: + cflags |= TCL_REG_NEWLINE; + break; + case REGEXP_LINESTOP: + cflags |= TCL_REG_NLSTOP; + break; + case REGEXP_LINEANCHOR: + cflags |= TCL_REG_NLANCH; + break; + case REGEXP_START: { + int temp; + if (++i >= objc) { + goto endOfForLoop; } - case REGEXP_START: { - int temp; - if (++i >= objc) { - goto endOfForLoop; - } - if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) { - goto optionError; - } - if (startIndex) { - Tcl_DecrRefCount(startIndex); - } - startIndex = objv[i]; - Tcl_IncrRefCount(startIndex); - break; + if (TclGetIntForIndex(interp, objv[i], 0, &temp) != TCL_OK) { + goto optionError; } - case REGEXP_LAST: { - i++; - goto endOfForLoop; + if (startIndex) { + Tcl_DecrRefCount(startIndex); } + startIndex = objv[i]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGEXP_LAST: + i++; + goto endOfForLoop; } } endOfForLoop: if ((objc - i) < (2 - about)) { - Tcl_WrongNumArgs(interp, 1, objv, + Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string ?matchVar? ?subMatchVar subMatchVar ...?"); goto optionError; } objc -= i; objv += i; + /* + * Check if the user requested -inline, but specified match variables; a + * no-no. + */ + if (doinline && ((objc - 2) != 0)) { - /* - * User requested -inline, but specified match variables - a no-no. - */ Tcl_AppendResult(interp, "regexp match variables not allowed", " when using -inline", (char *) NULL); goto optionError; @@ -203,6 +195,7 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * Handle the odd about case separately. */ + if (about) { regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); if ((regExpr == NULL) || (TclRegAbout(interp, regExpr) < 0)) { @@ -216,10 +209,11 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } /* - * Get the length of the string that we are matching against so - * we can do the termination test for -all matches. Do this before - * getting the regexp to avoid shimmering problems. + * Get the length of the string that we are matching against so we can do + * the termination test for -all matches. Do this before getting the + * regexp to avoid shimmering problems. */ + objPtr = objv[1]; stringLength = Tcl_GetCharLength(objPtr); @@ -238,9 +232,10 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) if (offset > 0) { /* - * Add flag if using offset (string is part of a larger string), - * so that "^" won't match. + * Add flag if using offset (string is part of a larger string), so + * that "^" won't match. */ + eflags |= TCL_REG_NOTBOL; } @@ -251,27 +246,28 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) /* * Save all the subexpressions, as we will return them as a list */ + numMatchesSaved = -1; } else { /* - * Save only enough subexpressions for matches we want to keep, - * expect in the case of -all, where we need to keep at least - * one to know where to move the offset. + * Save only enough subexpressions for matches we want to keep, expect + * in the case of -all, where we need to keep at least one to know + * where to move the offset. */ + numMatchesSaved = (objc == 0) ? all : objc; } /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match. If "-all" - * hasn't been specified then the loop body only gets executed once. - * We terminate the loop when the starting offset is past the end of the - * string. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match. If "-all" hasn't been + * specified then the loop body only gets executed once. We terminate the + * loop when the starting offset is past the end of the string. */ while (1) { match = Tcl_RegExpExecObj(interp, regExpr, objPtr, - offset /* offset */, numMatchesSaved, eflags + offset /* offset */, numMatchesSaved, eflags | ((offset > 0 && (Tcl_GetUniChar(objPtr,offset-1) != (Tcl_UniChar)'\n')) ? TCL_REG_NOTBOL : 0)); @@ -285,12 +281,14 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * We want to set the value of the intepreter result only when * this is the first time through the loop. */ + if (all <= 1) { /* - * If inlining, the interpreter's object result remains - * an empty list, otherwise set it to an integer object w/ - * value 0. + * If inlining, the interpreter's object result remains an + * empty list, otherwise set it to an integer object w/ value + * 0. */ + if (!doinline) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } @@ -300,16 +298,17 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } /* - * If additional variable names have been specified, return - * index information in those variables. + * If additional variable names have been specified, return index + * information in those variables. */ Tcl_RegExpGetInfo(regExpr, &info); if (doinline) { /* - * It's the number of substitutions, plus one for the matchVar - * at index 0 + * It's the number of substitutions, plus one for the matchVar at + * index 0 */ + objc = info.nsubs + 1; if (all <= 1) { resultPtr = Tcl_NewObj(); @@ -323,9 +322,10 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) Tcl_Obj *objs[2]; /* - * Only adjust the match area if there was a match for - * that area. (Scriptics Bug 4391/SF Bug #219232) + * Only adjust the match area if there was a match for that + * area. (Scriptics Bug 4391/SF Bug #219232) */ + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; @@ -378,15 +378,17 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) if (all == 0) { break; } + /* - * Adjust the offset to the character just after the last one - * in the matchVar and increment all to count how many times - * we are making a match. We always increment the offset by at least - * one to prevent endless looping (as in the case: - * regexp -all {a*} a). Otherwise, when we match the NULL string at - * the end of the input string, we will loop indefinately (because the - * length of the match is 0, so offset never changes). + * Adjust the offset to the character just after the last one in the + * matchVar and increment all to count how many times we are making a + * match. We always increment the offset by at least one to prevent + * endless looping (as in the case: regexp -all {a*} a). Otherwise, + * when we match the NULL string at the end of the input string, we + * will loop indefinately (because the length of the match is 0, so + * offset never changes). */ + if (info.matches[0].end == 0) { offset++; } @@ -399,9 +401,9 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) } /* - * Set the interpreter's object result to an integer object - * with value 1 if -all wasn't specified, otherwise it's all-1 - * (the number of times through the while - 1). + * Set the interpreter's object result to an integer object with value 1 + * if -all wasn't specified, otherwise it's all-1 (the number of times + * through the while - 1). */ if (doinline) { @@ -417,8 +419,8 @@ Tcl_RegexpObjCmd(dummy, interp, objc, objv) * * Tcl_RegsubObjCmd -- * - * This procedure is invoked to process the "regsub" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "regsub" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -463,7 +465,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) for (idx = 1; idx < objc; idx++) { char *name; int index; - + name = TclGetString(objv[idx]); if (name[0] != '-') { break; @@ -473,58 +475,52 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) goto optionError; } switch ((enum options) index) { - case REGSUB_ALL: { - all = 1; - break; - } - case REGSUB_NOCASE: { - cflags |= TCL_REG_NOCASE; - break; - } - case REGSUB_EXPANDED: { - cflags |= TCL_REG_EXPANDED; - break; - } - case REGSUB_LINE: { - cflags |= TCL_REG_NEWLINE; - break; - } - case REGSUB_LINESTOP: { - cflags |= TCL_REG_NLSTOP; - break; - } - case REGSUB_LINEANCHOR: { - cflags |= TCL_REG_NLANCH; - break; + case REGSUB_ALL: + all = 1; + break; + case REGSUB_NOCASE: + cflags |= TCL_REG_NOCASE; + break; + case REGSUB_EXPANDED: + cflags |= TCL_REG_EXPANDED; + break; + case REGSUB_LINE: + cflags |= TCL_REG_NEWLINE; + break; + case REGSUB_LINESTOP: + cflags |= TCL_REG_NLSTOP; + break; + case REGSUB_LINEANCHOR: + cflags |= TCL_REG_NLANCH; + break; + case REGSUB_START: { + int temp; + if (++idx >= objc) { + goto endOfForLoop; } - case REGSUB_START: { - int temp; - if (++idx >= objc) { - goto endOfForLoop; - } - if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) { - goto optionError; - } - if (startIndex) { - Tcl_DecrRefCount(startIndex); - } - startIndex = objv[idx]; - Tcl_IncrRefCount(startIndex); - break; + if (TclGetIntForIndex(interp, objv[idx], 0, &temp) != TCL_OK) { + goto optionError; } - case REGSUB_LAST: { - idx++; - goto endOfForLoop; + if (startIndex) { + Tcl_DecrRefCount(startIndex); } + startIndex = objv[idx]; + Tcl_IncrRefCount(startIndex); + break; + } + case REGSUB_LAST: + idx++; + goto endOfForLoop; } } + endOfForLoop: if (objc-idx < 3 || objc-idx > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? exp string subSpec ?varName?"); - optionError: + optionError: if (startIndex) { - Tcl_DecrRefCount(startIndex); + Tcl_DecrRefCount(startIndex); } return TCL_ERROR; } @@ -534,6 +530,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (startIndex) { int stringLength = Tcl_GetCharLength(objv[1]); + TclGetIntForIndex(NULL, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { @@ -545,9 +542,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* - * This is a simple one pair string map situation. We make use of - * a slightly modified version of the one pair STR_MAP code. + * This is a simple one pair string map situation. We make use of a + * slightly modified version of the one pair STR_MAP code. */ + int slen, nocase; int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, unsigned long)); @@ -565,9 +563,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) if (slen == 0) { /* - * regsub behavior for "" matches between each character. - * 'string map' skips the "" case. + * regsub behavior for "" matches between each character. 'string + * map' skips the "" case. */ + if (wstring < wend) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); @@ -581,10 +580,9 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { - if (((*wstring == *wsrc) || - (nocase && (Tcl_UniCharToLower(*wstring) == - wsrclc))) && - ((slen == 1) || (strCmpFn(wstring, wsrc, + if ((*wstring == *wsrc || + (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && + (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); @@ -618,9 +616,9 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } /* - * Make sure to avoid problems where the objects are shared. This - * can cause RegExpObj <> UnicodeObj shimmering that causes data - * corruption. [Bug #461322] + * Make sure to avoid problems where the objects are shared. This can + * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. + * [Bug #461322] */ if (objv[1] == objv[0]) { @@ -639,21 +637,21 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) result = TCL_OK; /* - * The following loop is to handle multiple matches within the - * same source string; each iteration handles one match and its - * corresponding substitution. If "-all" hasn't been specified - * then the loop body only gets executed once. We must use - * 'offset <= wlen' in particular for the case where the regexp - * pattern can match the empty string - this is useful when - * doing, say, 'regsub -- ^ $str ...' when $str might be empty. + * The following loop is to handle multiple matches within the same source + * string; each iteration handles one match and its corresponding + * substitution. If "-all" hasn't been specified then the loop body only + * gets executed once. We must use 'offset <= wlen' in particular for the + * case where the regexp pattern can match the empty string - this is + * useful when doing, say, 'regsub -- ^ $str ...' when $str might be + * empty. */ numMatches = 0; for ( ; offset <= wlen; ) { /* - * The flags argument is set if string is part of a larger string, - * so that "^" won't match. + * The flags argument is set if string is part of a larger string, so + * that "^" won't match. */ match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, @@ -673,9 +671,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(resultPtr); if (offset > 0) { /* - * Copy the initial portion of the string in if an offset - * was specified. + * Copy the initial portion of the string in if an offset was + * specified. */ + Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); } } @@ -721,10 +720,12 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } else { continue; } + if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } + if (idx <= info.nsubs) { subStart = info.matches[idx].start; subEnd = info.matches[idx].end; @@ -733,18 +734,21 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) wstring + offset + subStart, subEnd - subStart); } } + if (*wsrc == '\\') { wsrc++; } wfirstChar = wsrc + 1; } + if (wfirstChar != wsrc) { Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } + if (end == 0) { /* - * Always consume at least one character of the input string - * in order to prevent infinite loops. + * Always consume at least one character of the input string in + * order to prevent infinite loops. */ if (offset < wlen) { @@ -755,10 +759,10 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) offset += end; if (start == end) { /* - * We matched an empty string, which means we must go - * forward one more step so we don't match again at the - * same spot. + * We matched an empty string, which means we must go forward + * one more step so we don't match again at the same spot. */ + if (offset < wlen) { Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); } @@ -774,12 +778,14 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * Copy the portion of the source string after the last match to the * result variable. */ + regsubDone: if (numMatches == 0) { /* - * On zero matches, just ignore the offset, since it shouldn't - * matter to us in this case, and the user may have skewed it. + * On zero matches, just ignore the offset, since it shouldn't matter + * to us in this case, and the user may have skewed it. */ + resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { @@ -793,7 +799,7 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) } else { /* * Set the interpreter's object result to an integer object - * holding the number of matches. + * holding the number of matches. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); @@ -802,13 +808,20 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) /* * No varname supplied, so just return the modified string. */ + Tcl_SetObjResult(interp, resultPtr); } done: - if (objPtr && (objv[1] == objv[0])) { Tcl_DecrRefCount(objPtr); } - if (subPtr && (objv[2] == objv[0])) { Tcl_DecrRefCount(subPtr); } - if (resultPtr) { Tcl_DecrRefCount(resultPtr); } + if (objPtr && (objv[1] == objv[0])) { + Tcl_DecrRefCount(objPtr); + } + if (subPtr && (objv[2] == objv[0])) { + Tcl_DecrRefCount(subPtr); + } + if (resultPtr) { + Tcl_DecrRefCount(resultPtr); + } return result; } @@ -817,8 +830,8 @@ Tcl_RegsubObjCmd(dummy, interp, objc, objv) * * Tcl_RenameObjCmd -- * - * This procedure is invoked to process the "rename" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "rename" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -838,7 +851,7 @@ Tcl_RenameObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { char *oldName, *newName; - + if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "oldName newName"); return TCL_ERROR; @@ -881,6 +894,7 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ + int explicitResult = (0 == (objc % 2)); int numOptionWords = objc - 1 - explicitResult; @@ -901,8 +915,8 @@ Tcl_ReturnObjCmd(dummy, interp, objc, objv) * * Tcl_SourceObjCmd -- * - * This procedure is invoked to process the "source" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "source" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl object result. @@ -928,18 +942,22 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } + fileName = objv[objc-1]; + if (objc == 4) { static CONST char *options[] = { "-encoding", (char *) NULL }; int index; + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } + return Tcl_FSEvalFileEx(interp, fileName, encodingName); } @@ -948,8 +966,8 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv) * * Tcl_SplitObjCmd -- * - * This procedure is invoked to process the "split" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "split" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -987,7 +1005,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) stringPtr = Tcl_GetStringFromObj(objv[1], &stringLen); end = stringPtr + stringLen; listPtr = Tcl_NewObj(); - + if (stringLen == 0) { /* * Do nothing. @@ -1000,20 +1018,29 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) /* * Handle the special case of splitting on every character. * - * Uses a hash table to ensure that each kind of character has - * only one Tcl_Obj instance (multiply-referenced) in the - * final list. This is a *major* win when splitting on a long - * string (especially in the megabyte range!) - DKF + * Uses a hash table to ensure that each kind of character has only + * one Tcl_Obj instance (multiply-referenced) in the final list. This + * is a *major* win when splitting on a long string (especially in the + * megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); + for ( ; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); - /* Assume Tcl_UniChar is an integral type... */ + + /* + * Assume Tcl_UniChar is an integral type... + */ + hPtr = Tcl_CreateHashEntry(&charReuseTable, (char*)0 + ch, &isNew); if (isNew) { objPtr = Tcl_NewStringObj(stringPtr, len); - /* Don't need to fiddle with refcount... */ + + /* + * Don't need to fiddle with refcount... + */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); } else { objPtr = (Tcl_Obj*) Tcl_GetHashValue(hPtr); @@ -1021,13 +1048,14 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } Tcl_DeleteHashTable(&charReuseTable); + } else if (splitCharLen == 1) { char *p; /* - * Handle the special case of splitting on a single character. - * This is only true for the one-char ASCII case, as one unicode - * char is > 1 byte in length. + * Handle the special case of splitting on a single character. This + * is only true for the one-char ASCII case, as one unicode char is > + * 1 byte in length. */ while (*stringPtr && (p=strchr(stringPtr,(int)*splitChars)) != NULL) { @@ -1041,10 +1069,10 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) char *element, *p, *splitEnd; int splitLen; Tcl_UniChar splitChar; - + /* - * Normal case: split on any of a given set of characters. - * Discard instances of the split characters. + * Normal case: split on any of a given set of characters. Discard + * instances of the split characters. */ splitEnd = splitChars + splitCharLen; @@ -1061,6 +1089,7 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) } } } + objPtr = Tcl_NewStringObj(element, stringPtr - element); Tcl_ListObjAppendElement(NULL, listPtr, objPtr); } @@ -1073,15 +1102,14 @@ Tcl_SplitObjCmd(dummy, interp, objc, objv) * * Tcl_StringObjCmd -- * - * This procedure is invoked to process the "string" Tcl command. - * See the user documentation for details on what it does. Note - * that this command only functions correctly on properly formed - * Tcl UTF strings. + * This procedure is invoked to process the "string" Tcl command. See + * the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. * - * Note that the primary methods here (equal, compare, match, ...) - * have bytecode equivalents. You will find the code for those in - * tclExecute.c. The code here will only be used in the non-bc - * case (like in an 'eval'). + * Note that the primary methods here (equal, compare, match, ...) have + * bytecode equivalents. You will find the code for those in + * tclExecute.c. The code here will only be used in the non-bc case + * (like in an 'eval'). * * Results: * A standard Tcl result. @@ -1118,1297 +1146,1319 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) STR_REPLACE, STR_TOLOWER, STR_TOUPPER, STR_TOTITLE, STR_TRIM, STR_TRIMLEFT, STR_TRIMRIGHT, STR_WORDEND, STR_WORDSTART - }; + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?"); return TCL_ERROR; } - + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { - case STR_EQUAL: - case STR_COMPARE: { - /* - * Remember to keep code here in some sync with the - * byte-compiled versions in tclExecute.c (INST_STR_EQ, - * INST_STR_NEQ and INST_STR_CMP as well as the expr string - * comparison in INST_EQ/INST_NEQ/INST_LT/...). - */ - int i, match, length, nocase = 0, reqlength = -1; - typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *, - unsigned int)); - strCmpFn_t strCmpFn; - - if (objc < 4 || objc > 7) { - str_cmp_args: - Tcl_WrongNumArgs(interp, 2, objv, - "?-nocase? ?-length int? string1 string2"); - return TCL_ERROR; - } + case STR_EQUAL: + case STR_COMPARE: { + /* + * Remember to keep code here in some sync with the byte-compiled + * versions in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and + * INST_STR_CMP as well as the expr string comparison in + * INST_EQ/INST_NEQ/INST_LT/...). + */ - for (i = 2; i < objc-2; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) - && strncmp(string2, "-nocase", (size_t)length2) == 0) { - nocase = 1; - } else if ((length2 > 1) - && strncmp(string2, "-length", (size_t)length2) == 0) { - if (i+1 >= objc-2) { - goto str_cmp_args; - } - if (Tcl_GetIntFromObj(interp, objv[++i], - &reqlength) != TCL_OK) { - return TCL_ERROR; - } - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase or -length", - (char *) NULL); + int i, match, length, nocase = 0, reqlength = -1; + typedef int (*strCmpFn_t) _ANSI_ARGS_((const char *, const char *, + unsigned int)); + strCmpFn_t strCmpFn; + + if (objc < 4 || objc > 7) { + str_cmp_args: + Tcl_WrongNumArgs(interp, 2, objv, + "?-nocase? ?-length int? string1 string2"); + return TCL_ERROR; + } + + for (i = 2; i < objc-2; i++) { + string2 = Tcl_GetStringFromObj(objv[i], &length2); + if ((length2 > 1) + && strncmp(string2, "-nocase", (size_t)length2) == 0) { + nocase = 1; + } else if ((length2 > 1) + && strncmp(string2, "-length", (size_t)length2) == 0) { + if (i+1 >= objc-2) { + goto str_cmp_args; + } + if (Tcl_GetIntFromObj(interp, objv[++i], + &reqlength) != TCL_OK) { return TCL_ERROR; } + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase or -length", (char *) NULL); + return TCL_ERROR; } + } + + /* + * From now on, we only access the two objects at the end of the + * argument array. + */ + objv += objc-2; + + if ((reqlength == 0) || (objv[0] == objv[1])) { /* - * From now on, we only access the two objects at the end - * of the argument array. + * Always match at 0 chars of if it is the same obj. */ - objv += objc-2; - if ((reqlength == 0) || (objv[0] == objv[1])) { - /* - * Alway match at 0 chars of if it is the same obj. - */ + Tcl_SetObjResult(interp, + Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); + break; + } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && + objv[1]->typePtr == &tclByteArrayType) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some + * reason... :^) + */ - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj((enum options) index == STR_EQUAL)); - break; - } else if (!nocase && objv[0]->typePtr == &tclByteArrayType && - objv[1]->typePtr == &tclByteArrayType) { - /* - * Use binary versions of comparisons since that won't - * cause undue type conversions and it is much faster. - * Only do this if we're case-sensitive (which is all - * that really makes sense with byte arrays anyway, and - * we have no memcasecmp() for some reason... :^) - */ - string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) memcmp; - } else if ((objv[0]->typePtr == &tclStringType) - && (objv[1]->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args - * are of String type. In benchmark testing this proved - * the most efficient check between the unicode and - * string comparison operations. - */ - string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + string1 = (char*) Tcl_GetByteArrayFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetByteArrayFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) memcmp; + } else if ((objv[0]->typePtr == &tclStringType) + && (objv[1]->typePtr == &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. In benchmark testing this proved the most + * efficient check between the unicode and string comparison + * operations. + */ + + string1 = (char*) Tcl_GetUnicodeFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetUnicodeFromObj(objv[1], &length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp); + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use memcmp() + * as that is unsafe with any string containing NULL (\xC0\x80 in + * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if + * we are case-sensitive and no specific length was requested. + */ + + string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); + string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); + if ((reqlength < 0) && !nocase) { + strCmpFn = (strCmpFn_t) TclpUtfNcmp2; } else { + length1 = Tcl_NumUtfChars(string1, length1); + length2 = Tcl_NumUtfChars(string2, length2); + strCmpFn = (strCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + + if (((enum options) index == STR_EQUAL) + && (reqlength < 0) && (length1 != length2)) { + match = 1; /* this will be reversed below */ + } else { + length = (length1 < length2) ? length1 : length2; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { /* - * As a catch-all we will work with UTF-8. We cannot use - * memcmp() as that is unsafe with any string containing - * NULL (\xC0\x80 in Tcl's utf rep). We can use the more - * efficient TclpUtfNcmp2 if we are case-sensitive and no - * specific length was requested. + * The requested length is negative, so we ignore it by + * setting it to length + 1 so we correct the match var. */ - string1 = (char*) Tcl_GetStringFromObj(objv[0], &length1); - string2 = (char*) Tcl_GetStringFromObj(objv[1], &length2); - if ((reqlength < 0) && !nocase) { - strCmpFn = (strCmpFn_t) TclpUtfNcmp2; - } else { - length1 = Tcl_NumUtfChars(string1, length1); - length2 = Tcl_NumUtfChars(string2, length2); - strCmpFn = (strCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - if (((enum options) index == STR_EQUAL) - && (reqlength < 0) && (length1 != length2)) { - match = 1; /* this will be reversed below */ - } else { - length = (length1 < length2) ? length1 : length2; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by - * setting it to length + 1 so we correct the match var. - */ - reqlength = length + 1; - } - match = strCmpFn(string1, string2, (unsigned) length); - if ((match == 0) && (reqlength > length)) { - match = length1 - length2; - } + reqlength = length + 1; } - if ((enum options) index == STR_EQUAL) { - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); - } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj( - (match > 0) ? 1 : (match < 0) ? -1 : 0)); + match = strCmpFn(string1, string2, (unsigned) length); + if ((match == 0) && (reqlength > length)) { + match = length1 - length2; } - break; } - case STR_FIRST: { - Tcl_UniChar *ustring1, *ustring2; - int match, start; - - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); - return TCL_ERROR; - } - /* - * We are searching string2 for the sequence string1. - */ + if ((enum options) index == STR_EQUAL) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); + } else { + Tcl_SetObjResult(interp, Tcl_NewIntObj( + (match > 0) ? 1 : (match < 0) ? -1 : 0)); + } + break; + } + case STR_FIRST: { + Tcl_UniChar *ustring1, *ustring2; + int match, start; - match = -1; - start = 0; - length2 = -1; + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "subString string ?startIndex?"); + return TCL_ERROR; + } - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + /* + * We are searching string2 for the sequence string1. + */ - if (objc == 5) { - /* - * If a startIndex is specified, we will need to fast - * forward to that point in the string before we think - * about a match - */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start >= length2) { - goto str_first_done; - } else if (start > 0) { - ustring2 += start; - length2 -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; - * Bug #423581 - */ - start = 0; - } - } + match = -1; + start = 0; + length2 = -1; - if (length1 > 0) { - register Tcl_UniChar *p, *end; + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); - end = ustring2 + length2 - length1 + 1; - for (p = ustring2; p < end; p++) { - /* - * Scan forward to find the first character. - */ - if ((*p == *ustring1) && - (TclUniCharNcmp(ustring1, p, - (unsigned long) length1) == 0)) { - match = p - ustring2; - break; - } - } - } + if (objc == 5) { /* - * Compute the character index of the matching string by - * counting the number of characters before the match. + * If a startIndex is specified, we will need to fast forward to + * that point in the string before we think about a match */ - if ((match != -1) && (objc == 5)) { - match += start; - } - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); - break; - } - case STR_INDEX: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { return TCL_ERROR; } + if (start >= length2) { + goto str_first_done; + } else if (start > 0) { + ustring2 += start; + length2 -= start; + } else if (start < 0) { + /* + * Invalid start index mapped to string start; Bug #423581 + */ - /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the index'th char. - */ + start = 0; + } + } - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); + if (length1 > 0) { + register Tcl_UniChar *p, *end; - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *)(&string1[index]), 1)); - } - } else { + end = ustring2 + length2 - length1 + 1; + for (p = ustring2; p < end; p++) { /* - * Get Unicode char length to calulate what 'end' means. + * Scan forward to find the first character. */ - length1 = Tcl_GetCharLength(objv[2]); - - if (TclGetIntForIndex(interp, objv[3], length1 - 1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if ((index >= 0) && (index < length1)) { - char buf[TCL_UTF_MAX]; - Tcl_UniChar ch; - - ch = Tcl_GetUniChar(objv[2], index); - length1 = Tcl_UniCharToUtf(ch, buf); - Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); + if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p, + (unsigned long) length1) == 0)) { + match = p - ustring2; + break; } } - break; } - case STR_IS: { - char *end; - Tcl_UniChar ch; - /* - * The UniChar comparison function - */ + /* + * Compute the character index of the matching string by counting the + * number of characters before the match. + */ - int (*chcomp)_ANSI_ARGS_((int)) = NULL; - int i, failat = 0, result = 1, strict = 0; - Tcl_Obj *objPtr, *failVarObj = NULL; - Tcl_WideInt w; - - static CONST char *isOptions[] = { - "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "false", - "graph", "integer", "lower", "print", - "punct", "space", "true", "upper", - "wideinteger", "wordchar", "xdigit", (char *) NULL - }; - enum isOptions { - STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, - STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, - STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, - STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT - }; - - if (objc < 4 || objc > 7) { - Tcl_WrongNumArgs(interp, 2, objv, - "class ?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, - &index) != TCL_OK) { + if ((match != -1) && (objc == 5)) { + match += start; + } + + str_first_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + break; + } + case STR_INDEX: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string charIndex"); + return TCL_ERROR; + } + + /* + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the index'th char. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1); + + if (TclGetIntForIndex(interp, objv[3], length1 - 1, + &index) != TCL_OK) { return TCL_ERROR; } - if (objc != 4) { - for (i = 3; i < objc-1; i++) { - string2 = Tcl_GetStringFromObj(objv[i], &length2); - if ((length2 > 1) && - strncmp(string2, "-strict", (size_t) length2) == 0) { - strict = 1; - } else if ((length2 > 1) && - strncmp(string2, "-failindex", - (size_t) length2) == 0) { - if (i+1 >= objc-1) { - Tcl_WrongNumArgs(interp, 3, objv, - "?-strict? ?-failindex var? str"); - return TCL_ERROR; - } - failVarObj = objv[++i]; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -strict or -failindex", - (char *) NULL); - return TCL_ERROR; - } - } + if ((index >= 0) && (index < length1)) { + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *)(&string1[index]), 1)); } - + } else { /* - * We get the objPtr so that we can short-cut for some classes - * by checking the object type (int and double), but we need - * the string otherwise, because we don't want any conversion - * of type occuring (as, for example, Tcl_Get*FromObj would do + * Get Unicode char length to calulate what 'end' means. */ - objPtr = objv[objc-1]; - string1 = Tcl_GetStringFromObj(objPtr, &length1); - if (length1 == 0) { - if (strict) { - result = 0; - } - goto str_is_done; + + length1 = Tcl_GetCharLength(objv[2]); + + if (TclGetIntForIndex(interp, objv[3], length1 - 1, + &index) != TCL_OK) { + return TCL_ERROR; } - end = string1 + length1; + if ((index >= 0) && (index < length1)) { + char buf[TCL_UTF_MAX]; + Tcl_UniChar ch; - /* - * When entering here, result == 1 and failat == 0 - */ - switch ((enum isOptions) index) { - case STR_IS_ALNUM: - chcomp = Tcl_UniCharIsAlnum; - break; - case STR_IS_ALPHA: - chcomp = Tcl_UniCharIsAlpha; - break; - case STR_IS_ASCII: - for (; string1 < end; string1++, failat++) { - /* - * This is a valid check in unicode, because all - * bytes < 0xC0 are single byte chars (but isascii - * limits that def'n to 0x80). - */ - if (*((unsigned char *)string1) >= 0x80) { - result = 0; - break; - } - } - break; - case STR_IS_BOOL: - case STR_IS_TRUE: - case STR_IS_FALSE: - if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, - &tclBooleanType)) { - result = 0; - } else if ((((enum isOptions) index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) || - (((enum isOptions) index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { - result = 0; - } - break; - case STR_IS_CONTROL: - chcomp = Tcl_UniCharIsControl; - break; - case STR_IS_DIGIT: - chcomp = Tcl_UniCharIsDigit; - break; - case STR_IS_DOUBLE: { - char *stop; + ch = Tcl_GetUniChar(objv[2], index); + length1 = Tcl_UniCharToUtf(ch, buf); + Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length1)); + } + } + break; + } + case STR_IS: { + char *end; + Tcl_UniChar ch; - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType)) { - break; - } - /* - * This is adapted from Tcl_GetDouble - * - * The danger in this function is that - * "12345678901234567890" is an acceptable 'double', - * but will later be interp'd as an int by something - * like [expr]. Therefore, we check to see if it looks - * like an int, and if so we do a range check on it. - * If strtoul gets to the end, we know we either - * received an acceptable int, or over/underflow - */ - if (TclLooksLikeInt(string1, length1)) { - errno = 0; -#ifdef TCL_WIDE_INT_IS_LONG - strtoul(string1, &stop, 0); /* INTL: Tcl source. */ -#else - strtoull(string1, &stop, 0); /* INTL: Tcl source. */ -#endif - if (stop == end) { - if (errno == ERANGE) { - result = 0; - failat = -1; - } - break; - } - } - errno = 0; - TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */ - if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - result = 0; - failat = 0; - } else { - /* - * Assume we sucked up one char per byte - * and then we go onto SPACE, since we are - * allowed trailing whitespace - */ - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; + /* + * The UniChar comparison function + */ + + int (*chcomp)_ANSI_ARGS_((int)) = NULL; + int i, failat = 0, result = 1, strict = 0; + Tcl_Obj *objPtr, *failVarObj = NULL; + Tcl_WideInt w; + + static CONST char *isOptions[] = { + "alnum", "alpha", "ascii", "control", + "boolean", "digit", "double", "false", + "graph", "integer", "lower", "print", + "punct", "space", "true", "upper", + "wideinteger", "wordchar", "xdigit", (char *) NULL + }; + enum isOptions { + STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, + STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_FALSE, + STR_IS_GRAPH, STR_IS_INT, STR_IS_LOWER, STR_IS_PRINT, + STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, + STR_IS_WIDE, STR_IS_WORD, STR_IS_XDIGIT + }; + + if (objc < 4 || objc > 7) { + Tcl_WrongNumArgs(interp, 2, objv, + "class ?-strict? ?-failindex var? str"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[2], isOptions, "class", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (objc != 4) { + for (i = 3; i < objc-1; i++) { + string2 = Tcl_GetStringFromObj(objv[i], &length2); + if ((length2 > 1) && + strncmp(string2, "-strict", (size_t) length2) == 0) { + strict = 1; + } else if ((length2 > 1) && + strncmp(string2, "-failindex", (size_t) length2) == 0){ + if (i+1 >= objc-1) { + Tcl_WrongNumArgs(interp, 3, objv, + "?-strict? ?-failindex var? str"); + return TCL_ERROR; } - break; + failVarObj = objv[++i]; + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -strict or -failindex", (char *)NULL); + return TCL_ERROR; } - case STR_IS_GRAPH: - chcomp = Tcl_UniCharIsGraph; - break; - case STR_IS_INT: { - char *stop; - long int l = 0; + } + } - if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { - break; - } + /* + * We get the objPtr so that we can short-cut for some classes by + * checking the object type (int and double), but we need the string + * otherwise, because we don't want any conversion of type occuring + * (as, for example, Tcl_Get*FromObj would do + */ - /* - * Like STR_IS_DOUBLE, but we use strtoul. - * Since Tcl_GetIntFromObj already failed, - * we set result to 0. - */ + objPtr = objv[objc-1]; + string1 = Tcl_GetStringFromObj(objPtr, &length1); + if (length1 == 0) { + if (strict) { + result = 0; + } + goto str_is_done; + } + end = string1 + length1; + /* + * When entering here, result == 1 and failat == 0 + */ + + switch ((enum isOptions) index) { + case STR_IS_ALNUM: + chcomp = Tcl_UniCharIsAlnum; + break; + case STR_IS_ALPHA: + chcomp = Tcl_UniCharIsAlpha; + break; + case STR_IS_ASCII: + for (; string1 < end; string1++, failat++) { + /* + * This is a valid check in unicode, because all bytes less + * than 0xC0 are single byte chars (but isascii limits that + * def'n to 0x80). + */ + + if (*((unsigned char *)string1) >= 0x80) { result = 0; - errno = 0; - l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ - if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { - /* - * if (errno == ERANGE) or the long value - * won't fit in an int, then it was an - * over/underflow problem, but in this method, - * we only want to know yes or no, so bad flow - * returns 0 (false) and sets the failVarObj - * to the string length. - */ - failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - failat = 0; - } else { - /* - * Assume we sucked up one char per byte - * and then we go onto SPACE, since we are - * allowed trailing whitespace - */ - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; - } break; } - case STR_IS_LOWER: - chcomp = Tcl_UniCharIsLower; - break; - case STR_IS_PRINT: - chcomp = Tcl_UniCharIsPrint; - break; - case STR_IS_PUNCT: - chcomp = Tcl_UniCharIsPunct; - break; - case STR_IS_SPACE: - chcomp = Tcl_UniCharIsSpace; - break; - case STR_IS_UPPER: - chcomp = Tcl_UniCharIsUpper; - break; - case STR_IS_WIDE: { - char *stop; + } + break; + case STR_IS_BOOL: + case STR_IS_TRUE: + case STR_IS_FALSE: + if (TCL_OK != Tcl_ConvertToType(NULL, objPtr, &tclBooleanType)) { + result = 0; + } else if ((((enum isOptions) index == STR_IS_TRUE) && + objPtr->internalRep.longValue == 0) || + (((enum isOptions) index == STR_IS_FALSE) && + objPtr->internalRep.longValue != 0)) { + result = 0; + } + break; + case STR_IS_CONTROL: + chcomp = Tcl_UniCharIsControl; + break; + case STR_IS_DIGIT: + chcomp = Tcl_UniCharIsDigit; + break; + case STR_IS_DOUBLE: { + char *stop; - if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { - break; - } + if ((objPtr->typePtr == &tclDoubleType) || + (objPtr->typePtr == &tclIntType)) { + break; + } - /* - * Like STR_IS_DOUBLE, but we use strtoll. Since - * Tcl_GetWideIntFromObj already failed, we set - * result to 0. - */ + /* + * This is adapted from Tcl_GetDouble + * + * The danger in this function is that "12345678901234567890" is + * an acceptable 'double', but will later be interp'd as an int by + * something like [expr]. Therefore, we check to see if it looks + * like an int, and if so we do a range check on it. If strtoul + * gets to the end, we know we either received an acceptable int, + * or over/underflow. + */ - result = 0; - errno = 0; - w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ + if (TclLooksLikeInt(string1, length1)) { + errno = 0; +#ifdef TCL_WIDE_INT_IS_LONG + strtoul(string1, &stop, 0); /* INTL: Tcl source. */ +#else + strtoull(string1, &stop, 0); /* INTL: Tcl source. */ +#endif + if (stop == end) { if (errno == ERANGE) { - /* - * if (errno == ERANGE), then it was an - * over/underflow problem, but in this method, - * we only want to know yes or no, so bad flow - * returns 0 (false) and sets the failVarObj - * to the string length. - */ + result = 0; failat = -1; - } else if (stop == string1) { - /* - * In this case, nothing like a number was found - */ - failat = 0; - } else { - /* - * Assume we sucked up one char per byte and - * then we go onto SPACE, since we are allowed - * trailing whitespace - */ - failat = stop - string1; - string1 = stop; - chcomp = Tcl_UniCharIsSpace; - } - break; - } - case STR_IS_WORD: - chcomp = Tcl_UniCharIsWordChar; - break; - case STR_IS_XDIGIT: { - for (; string1 < end; string1++, failat++) { - /* INTL: We assume unicode is bad for this class */ - if ((*((unsigned char *)string1) >= 0xC0) || - !isxdigit(*(unsigned char *)string1)) { - result = 0; - break; - } } break; } } - if (chcomp != NULL) { - for (; string1 < end; string1 += length2, failat++) { - length2 = TclUtfToUniChar(string1, &ch); - if (!chcomp(ch)) { - result = 0; - break; - } - } + errno = 0; + TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */ + if (stop == string1) { + /* + * In this case, nothing like a number was found. + */ + + result = 0; + failat = 0; + } else { + /* + * Assume we sucked up one char per byte and then we go onto + * SPACE, since we are allowed trailing whitespace. + */ + + failat = stop - string1; + string1 = stop; + chcomp = Tcl_UniCharIsSpace; } - str_is_done: + break; + } + case STR_IS_GRAPH: + chcomp = Tcl_UniCharIsGraph; + break; + case STR_IS_INT: { + char *stop; + long int l = 0; + + if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) { + break; + } + /* - * Only set the failVarObj when we will return 0 - * and we have indicated a valid fail index (>= 0) + * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj + * already failed, we set result to 0. */ - if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), - TCL_LEAVE_ERR_MSG) == NULL) { - return TCL_ERROR; + + result = 0; + errno = 0; + l = strtol(string1, &stop, 0); /* INTL: Tcl source. */ + if ((errno == ERANGE) || (l > INT_MAX) || (l < INT_MIN)) { + /* + * if (errno == ERANGE) or the long value won't fit in an int, + * then it was an over/underflow problem, but in this method, + * we only want to know yes or no, so bad flow returns 0 + * (false) and sets the failVarObj to the string length. + */ + + failat = -1; + } else if (stop == string1) { + /* + * In this case, nothing like a number was found + */ + + failat = 0; + } else { + /* + * Assume we sucked up one char per byte and then we go onto + * SPACE, since we are allowed trailing whitespace. + */ + + failat = stop - string1; + string1 = stop; + chcomp = Tcl_UniCharIsSpace; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); break; } - case STR_LAST: { - Tcl_UniChar *ustring1, *ustring2, *p; - int match, start; + case STR_IS_LOWER: + chcomp = Tcl_UniCharIsLower; + break; + case STR_IS_PRINT: + chcomp = Tcl_UniCharIsPrint; + break; + case STR_IS_PUNCT: + chcomp = Tcl_UniCharIsPunct; + break; + case STR_IS_SPACE: + chcomp = Tcl_UniCharIsSpace; + break; + case STR_IS_UPPER: + chcomp = Tcl_UniCharIsUpper; + break; + case STR_IS_WIDE: { + char *stop; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "subString string ?startIndex?"); - return TCL_ERROR; + if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) { + break; } /* - * We are searching string2 for the sequence string1. + * Like STR_IS_DOUBLE, but we use strtoll. Since + * Tcl_GetWideIntFromObj already failed, we set result to 0. */ - match = -1; - start = 0; - length2 = -1; - - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + result = 0; + errno = 0; + w = strtoll(string1, &stop, 0); /* INTL: Tcl source. */ + if (errno == ERANGE) { + /* + * if (errno == ERANGE), then it was an over/underflow + * problem, but in this method, we only want to know yes or + * no, so bad flow returns 0 (false) and sets the failVarObj + * to the string length. + */ - if (objc == 5) { + failat = -1; + } else if (stop == string1) { /* - * If a startIndex is specified, we will need to restrict - * the string range to that char index in the string + * In this case, nothing like a number was found */ - if (TclGetIntForIndex(interp, objv[4], length2 - 1, - &start) != TCL_OK) { - return TCL_ERROR; - } - if (start < 0) { - goto str_last_done; - } else if (start < length2) { - p = ustring2 + start + 1 - length1; - } else { - p = ustring2 + length2 - length1; - } + failat = 0; } else { - p = ustring2 + length2 - length1; - } + /* + * Assume we sucked up one char per byte and then we go onto + * SPACE, since we are allowed trailing whitespace. + */ - if (length1 > 0) { - for (; p >= ustring2; p--) { - /* - * Scan backwards to find the first character. - */ - if ((*p == *ustring1) && - (memcmp((char *) ustring1, (char *) p, (size_t) - (length1 * sizeof(Tcl_UniChar))) == 0)) { - match = p - ustring2; - break; - } + failat = stop - string1; + string1 = stop; + chcomp = Tcl_UniCharIsSpace; + } + break; + } + case STR_IS_WORD: + chcomp = Tcl_UniCharIsWordChar; + break; + case STR_IS_XDIGIT: + for (; string1 < end; string1++, failat++) { + /* INTL: We assume unicode is bad for this class */ + if ((*((unsigned char *)string1) >= 0xC0) || + !isxdigit(*(unsigned char *)string1)) { + result = 0; + break; } } - - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); break; } - case STR_BYTELENGTH: - case STR_LENGTH: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "string"); - return TCL_ERROR; + if (chcomp != NULL) { + for (; string1 < end; string1 += length2, failat++) { + length2 = TclUtfToUniChar(string1, &ch); + if (!chcomp(ch)) { + result = 0; + break; + } } + } - if ((enum options) index == STR_BYTELENGTH) { - (void) Tcl_GetStringFromObj(objv[2], &length1); + /* + * Only set the failVarObj when we will return 0 and we have indicated + * a valid fail index (>= 0). + */ + + str_is_done: + if ((result == 0) && (failVarObj != NULL) && + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + break; + } + case STR_LAST: { + Tcl_UniChar *ustring1, *ustring2, *p; + int match, start; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, + "subString string ?startIndex?"); + return TCL_ERROR; + } + + /* + * We are searching string2 for the sequence string1. + */ + + match = -1; + start = 0; + length2 = -1; + + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2); + + if (objc == 5) { + /* + * If a startIndex is specified, we will need to restrict the + * string range to that char index in the string + */ + + if (TclGetIntForIndex(interp, objv[4], length2 - 1, + &start) != TCL_OK) { + return TCL_ERROR; + } + if (start < 0) { + goto str_last_done; + } else if (start < length2) { + p = ustring2 + start + 1 - length1; } else { + p = ustring2 + length2 - length1; + } + } else { + p = ustring2 + length2 - length1; + } + + if (length1 > 0) { + for (; p >= ustring2; p--) { /* - * If we have a ByteArray object, avoid recomputing the - * string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * calculate the length. + * Scan backwards to find the first character. */ - if (objv[2]->typePtr == &tclByteArrayType) { - (void) Tcl_GetByteArrayFromObj(objv[2], &length1); - } else { - length1 = Tcl_GetCharLength(objv[2]); + if ((*p == *ustring1) && + (memcmp((char *) ustring1, (char *) p, (size_t) + (length1 * sizeof(Tcl_UniChar))) == 0)) { + match = p - ustring2; + break; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); - break; } - case STR_MAP: { - int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; - Tcl_Obj **mapElemv, *sourceObj, *resultPtr; - Tcl_UniChar *ustring1, *ustring2, *p, *end; - int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar*, - CONST Tcl_UniChar*, unsigned long)); - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + break; + } + case STR_BYTELENGTH: + case STR_LENGTH: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "string"); + return TCL_ERROR; + } + + if ((enum options) index == STR_BYTELENGTH) { + (void) Tcl_GetStringFromObj(objv[2], &length1); + } else { + /* + * If we have a ByteArray object, avoid recomputing the string + * since the byte array contains one byte per character. + * Otherwise, use the Unicode string rep to calculate the length. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + (void) Tcl_GetByteArrayFromObj(objv[2], &length1); + } else { + length1 = Tcl_GetCharLength(objv[2]); + } + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(length1)); + break; + case STR_MAP: { + int mapElemc, nocase = 0, mapWithDict = 0, copySource = 0; + Tcl_Obj **mapElemv, *sourceObj, *resultPtr; + Tcl_UniChar *ustring1, *ustring2, *p, *end; + int (*strCmpFn)_ANSI_ARGS_((CONST Tcl_UniChar *, CONST Tcl_UniChar *, + unsigned long)); + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? charMap string"); + return TCL_ERROR; + } + + if (objc == 5) { + string2 = Tcl_GetStringFromObj(objv[2], &length2); + if ((length2 > 1) && + strncmp(string2, "-nocase", (size_t) length2) == 0) { + nocase = 1; + } else { + Tcl_AppendResult(interp, "bad option \"", string2, + "\": must be -nocase", (char *) NULL); return TCL_ERROR; } + } - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase", (char *) NULL); - return TCL_ERROR; - } + /* + * This test is tricky, but has to be that way or you get other + * strange inconsistencies (see test string-10.20 for illustration + * why!) + */ + + if (objv[objc-2]->typePtr == &tclDictType && + objv[objc-2]->bytes == NULL) { + int i, done; + Tcl_DictSearch search; + + /* + * We know the type exactly, so all dict operations will succeed + * for sure. This shortens this code quite a bit. + */ + + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { + /* + * empty charMap, just return whatever string was given + */ + + Tcl_SetObjResult(interp, objv[objc-1]); + return TCL_OK; } + mapElemc *= 2; + mapWithDict = 1; /* - * This test is tricky, but has to be that way or you get - * other strange inconsistencies (see test string-10.20 - * for illustration why!) + * Copy the dictionary out into an array; that's the easiest way + * to adapt this code... */ - if (objv[objc-2]->typePtr == &tclDictType && - objv[objc-2]->bytes == NULL) { - int i, done; - Tcl_DictSearch search; + mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc); + Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, + mapElemv+1, &done); + for (i=2 ; i30% faster on + * larger strings. + */ + + int mapLen; + Tcl_UniChar *mapString, u2lc; + + ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + p = ustring1; + if ((length2 > length1) || (length2 == 0)) { + /* + * Match string is either longer than input or empty. + */ + + ustring1 = end; } else { - if (Tcl_ListObjGetElements(interp, objv[objc-2], - &mapElemc, &mapElemv) != TCL_OK) { - return TCL_ERROR; + mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); + for (; ustring1 < end; ustring1++) { + if (((*ustring1 == *ustring2) || + (nocase && Tcl_UniCharToLower(*ustring1)==u2lc)) && + (length2==1 || strCmpFn(ustring1, ustring2, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + ustring1 = p - 1; + + Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + } } - if (mapElemc == 0) { - /* - * empty charMap, just return whatever string was given - */ - Tcl_SetObjResult(interp, objv[objc-1]); - return TCL_OK; - } else if (mapElemc & 1) { + } + } else { + Tcl_UniChar **mapStrings, *u2lc = NULL; + int *mapLens; + + /* + * Precompute pointers to the unicode string and length. This + * saves us repeated function calls later, significantly speeding + * up the algorithm. We only need the lowercase first char in the + * nocase case. + */ + + mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) + * sizeof(Tcl_UniChar *)); + mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); + if (nocase) { + u2lc = (Tcl_UniChar *) + ckalloc((mapElemc) * sizeof(Tcl_UniChar)); + } + for (index = 0; index < mapElemc; index++) { + mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + &(mapLens[index])); + if (nocase && ((index % 2) == 0)) { + u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); + } + } + for (p = ustring1; ustring1 < end; ustring1++) { + for (index = 0; index < mapElemc; index += 2) { /* - * The charMap must be an even number of key/value items + * Get the key string to match on. */ - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "char map list unbalanced", -1)); - return TCL_ERROR; + + ustring2 = mapStrings[index]; + length2 = mapLens[index]; + if ((length2 > 0) && ((*ustring1 == *ustring2) || + (nocase && (Tcl_UniCharToLower(*ustring1) == + u2lc[index/2]))) && + /* restrict max compare length */ + ((end - ustring1) >= length2) && + ((length2 == 1) || strCmpFn(ustring2, ustring1, + (unsigned long) length2) == 0)) { + if (p != ustring1) { + /* + * Put the skipped chars onto the result first. + */ + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + p = ustring1 + length2; + } else { + p += length2; + } + + /* + * Adjust len to be full length of matched string. + */ + + ustring1 = p - 1; + + /* + * Append the map value to the unicode string. + */ + + Tcl_AppendUnicodeToObj(resultPtr, + mapStrings[index+1], mapLens[index+1]); + break; + } } } - + ckfree((char *) mapStrings); + ckfree((char *) mapLens); + if (nocase) { + ckfree((char *) u2lc); + } + } + if (p != ustring1) { /* - * Take a copy of the source string object if it is the - * same as the map string to cut out nasty sharing - * crashes. [Bug 1018562] + * Put the rest of the unmapped chars onto result. */ - if (objv[objc-2] == objv[objc-1]) { - sourceObj = Tcl_DuplicateObj(objv[objc-1]); - copySource = 1; + + Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + } + if (mapWithDict) { + ckfree((char *) mapElemv); + } + if (copySource) { + Tcl_DecrRefCount(sourceObj); + } + Tcl_SetObjResult(interp, resultPtr); + break; + } + case STR_MATCH: { + Tcl_UniChar *ustring1, *ustring2; + int nocase = 0; + + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); + return TCL_ERROR; + } + + if (objc == 5) { + string2 = Tcl_GetStringFromObj(objv[2], &length2); + if ((length2 > 1) && + strncmp(string2, "-nocase", (size_t) length2) == 0) { + nocase = 1; } else { - sourceObj = objv[objc-1]; + Tcl_AppendResult(interp, "bad option \"", + string2, "\": must be -nocase", (char *) NULL); + return TCL_ERROR; } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); - if (length1 == 0) { - /* - * Empty input string, just stop now - */ - if (mapWithDict) { - ckfree((char *) mapElemv); - } - if (copySource) { - Tcl_DecrRefCount(sourceObj); - } - break; + } + ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); + ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( + ustring1, length1, ustring2, length2, nocase))); + break; + } + case STR_RANGE: { + int first, last; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "string first last"); + return TCL_ERROR; + } + + /* + * If we have a ByteArray object, avoid indexing in the Utf string + * since the byte array contains one byte per character. Otherwise, + * use the Unicode string rep to get the range. + */ + + if (objv[2]->typePtr == &tclByteArrayType) { + string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); + length1--; + } else { + /* + * Get the length in actual characters. + */ + + string1 = NULL; + length1 = Tcl_GetCharLength(objv[2]) - 1; + } + + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || + TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { + return TCL_ERROR; + } + + if (first < 0) { + first = 0; + } + if (last >= length1) { + last = length1; + } + if (last >= first) { + if (string1 != NULL) { + int numBytes = last - first + 1; + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( + (unsigned char *) &string1[first], numBytes)); + } else { + Tcl_SetObjResult(interp, + Tcl_GetRange(objv[2], first, last)); } - end = ustring1 + length1; + } + break; + } + case STR_REPEAT: { + int count; - strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string count"); + return TCL_ERROR; + } - /* - * Force result to be Unicode - */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { + return TCL_ERROR; + } - if (mapElemc == 2) { + if (count == 1) { + Tcl_SetObjResult(interp, objv[2]); + } else if (count > 1) { + string1 = Tcl_GetStringFromObj(objv[2], &length1); + if (length1 > 0) { /* - * Special case for one map pair which avoids the extra - * for loop and extra calls to get Unicode data. The - * algorithm is otherwise identical to the multi-pair case. - * This will be >30% faster on larger strings. + * Only build up a string that has data. Instead of building + * it up with repeated appends, we just allocate the necessary + * space once and copy the string value in. Check for + * overflow with back-division. [Bug #714106] */ - int mapLen; - Tcl_UniChar *mapString, u2lc; - - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); - p = ustring1; - if ((length2 > length1) || (length2 == 0)) { - /* match string is either longer than input or empty */ - ustring1 = end; - } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); - u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); - for (; ustring1 < end; ustring1++) { - if (((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc))) && - ((length2 == 1) || strCmpFn(ustring1, ustring2, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - ustring1 = p - 1; - - Tcl_AppendUnicodeToObj(resultPtr, mapString, - mapLen); - } - } + + Tcl_Obj *resultPtr; + length2 = length1 * count; + if ((length2 / count) != length1) { + char buf[TCL_INTEGER_SPACE+1]; + sprintf(buf, "%d", INT_MAX); + Tcl_AppendResult(interp, + "string size overflow, must be less than ", + buf, (char *) NULL); + return TCL_ERROR; } - } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; + /* - * Precompute pointers to the unicode string and length. - * This saves us repeated function calls later, - * significantly speeding up the algorithm. We only need - * the lowercase first char in the nocase case. + * Include space for the NULL. */ - mapStrings = (Tcl_UniChar **) ckalloc((mapElemc * 2) - * sizeof(Tcl_UniChar *)); - mapLens = (int *) ckalloc((mapElemc * 2) * sizeof(int)); - if (nocase) { - u2lc = (Tcl_UniChar *) - ckalloc((mapElemc) * sizeof(Tcl_UniChar)); - } - for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], - &(mapLens[index])); - if (nocase && ((index % 2) == 0)) { - u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); - } - } - for (p = ustring1; ustring1 < end; ustring1++) { - for (index = 0; index < mapElemc; index += 2) { - /* - * Get the key string to match on. - */ - ustring2 = mapStrings[index]; - length2 = mapLens[index]; - if ((length2 > 0) && ((*ustring1 == *ustring2) || - (nocase && (Tcl_UniCharToLower(*ustring1) == - u2lc[index/2]))) && - /* restrict max compare length */ - ((end - ustring1) >= length2) && - ((length2 == 1) || strCmpFn(ustring2, ustring1, - (unsigned long) length2) == 0)) { - if (p != ustring1) { - /* - * Put the skipped chars onto the result first - */ - Tcl_AppendUnicodeToObj(resultPtr, p, - ustring1 - p); - p = ustring1 + length2; - } else { - p += length2; - } - /* - * Adjust len to be full length of matched string - */ - ustring1 = p - 1; - /* - * Append the map value to the unicode string - */ - Tcl_AppendUnicodeToObj(resultPtr, - mapStrings[index+1], mapLens[index+1]); - break; - } - } + string2 = (char *) ckalloc((size_t) length2+1); + for (index = 0; index < count; index++) { + memcpy(string2 + (length1 * index), string1, + (size_t) length1); } - ckfree((char *) mapStrings); - ckfree((char *) mapLens); - if (nocase) { - ckfree((char *) u2lc); - } - } - if (p != ustring1) { + string2[length2] = '\0'; + /* - * Put the rest of the unmapped chars onto result + * We have to directly assign this instead of using + * Tcl_SetStringObj (and indirectly TclInitStringRep) because + * that makes another copy of the data. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); - } - if (mapWithDict) { - ckfree((char *) mapElemv); - } - if (copySource) { - Tcl_DecrRefCount(sourceObj); - } - Tcl_SetObjResult(interp, resultPtr); - break; - } - case STR_MATCH: { - Tcl_UniChar *ustring1, *ustring2; - int nocase = 0; - if (objc < 4 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string"); - return TCL_ERROR; - } - - if (objc == 5) { - string2 = Tcl_GetStringFromObj(objv[2], &length2); - if ((length2 > 1) && - strncmp(string2, "-nocase", (size_t) length2) == 0) { - nocase = 1; - } else { - Tcl_AppendResult(interp, "bad option \"", - string2, "\": must be -nocase", (char *) NULL); - return TCL_ERROR; - } + TclNewObj(resultPtr); + resultPtr->bytes = string2; + resultPtr->length = length2; + Tcl_SetObjResult(interp, resultPtr); } - ustring1 = Tcl_GetUnicodeFromObj(objv[objc-1], &length1); - ustring2 = Tcl_GetUnicodeFromObj(objv[objc-2], &length2); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(TclUniCharMatch( - ustring1, length1, ustring2, length2, nocase))); - break; } - case STR_RANGE: { - int first, last; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string first last"); - return TCL_ERROR; - } + break; + } + case STR_REPLACE: { + Tcl_UniChar *ustring1; + int first, last; - /* - * If we have a ByteArray object, avoid indexing in the - * Utf string since the byte array contains one byte per - * character. Otherwise, use the Unicode string rep to - * get the range. - */ + if (objc < 5 || objc > 6) { + Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?"); + return TCL_ERROR; + } - if (objv[2]->typePtr == &tclByteArrayType) { - string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1); - length1--; - } else { - /* - * Get the length in actual characters. - */ - string1 = NULL; - length1 = Tcl_GetCharLength(objv[2]) - 1; - } + ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); + length1--; - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK || + TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) { + return TCL_ERROR; + } + if ((last < first) || (last < 0) || (first > length1)) { + Tcl_SetObjResult(interp, objv[2]); + } else { + Tcl_Obj *resultPtr; if (first < 0) { first = 0; } - if (last >= length1) { - last = length1; + + resultPtr = Tcl_NewUnicodeObj(ustring1, first); + if (objc == 6) { + Tcl_AppendObjToObj(resultPtr, objv[5]); } - if (last >= first) { - if (string1 != NULL) { - int numBytes = last - first + 1; - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char *) &string1[first], numBytes)); - } else { - Tcl_SetObjResult(interp, - Tcl_GetRange(objv[2], first, last)); - } + if (last < length1) { + Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, + length1 - last); } - break; + Tcl_SetObjResult(interp, resultPtr); + } + break; + } + case STR_TOLOWER: + case STR_TOUPPER: + case STR_TOTITLE: + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); + return TCL_ERROR; } - case STR_REPEAT: { - int count; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string count"); - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) { - return TCL_ERROR; - } + string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (count == 1) { - Tcl_SetObjResult(interp, objv[2]); - } else if (count > 1) { - string1 = Tcl_GetStringFromObj(objv[2], &length1); - if (length1 > 0) { - /* - * Only build up a string that has data. Instead of - * building it up with repeated appends, we just allocate - * the necessary space once and copy the string value in. - * Check for overflow with back-division. [Bug #714106] - */ - Tcl_Obj *resultPtr; - length2 = length1 * count; - if ((length2 / count) != length1) { - char buf[TCL_INTEGER_SPACE+1]; - sprintf(buf, "%d", INT_MAX); - Tcl_AppendResult(interp, - "string size overflow, must be less than ", - buf, (char *) NULL); - return TCL_ERROR; - } - /* - * Include space for the NULL - */ - string2 = (char *) ckalloc((size_t) length2+1); - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, - (size_t) length1); - } - string2[length2] = '\0'; - /* - * We have to directly assign this instead of using - * Tcl_SetStringObj (and indirectly TclInitStringRep) - * because that makes another copy of the data. - */ - resultPtr = Tcl_NewObj(); - resultPtr->bytes = string2; - resultPtr->length = length2; - Tcl_SetObjResult(interp, resultPtr); - } + if (objc == 3) { + Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); + if ((enum options) index == STR_TOLOWER) { + length1 = Tcl_UtfToLower(TclGetString(resultPtr)); + } else if ((enum options) index == STR_TOUPPER) { + length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); + } else { + length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); } - break; - } - case STR_REPLACE: { - Tcl_UniChar *ustring1; + Tcl_SetObjLength(resultPtr, length1); + Tcl_SetObjResult(interp, resultPtr); + } else { int first, last; + CONST char *start, *end; + Tcl_Obj *resultPtr; - if (objc < 5 || objc > 6) { - Tcl_WrongNumArgs(interp, 2, objv, - "string first last ?string?"); + length1 = Tcl_NumUtfChars(string1, length1) - 1; + if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK){ return TCL_ERROR; } + if (first < 0) { + first = 0; + } + last = first; - ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1); - length1--; - - if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK) - || (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { + if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, + &last) != TCL_OK)) { return TCL_ERROR; } - if ((last < first) || (last < 0) || (first > length1)) { - Tcl_SetObjResult(interp, objv[2]); - } else { - Tcl_Obj *resultPtr; - if (first < 0) { - first = 0; - } - - resultPtr = Tcl_NewUnicodeObj(ustring1, first); - if (objc == 6) { - Tcl_AppendObjToObj(resultPtr, objv[5]); - } - if (last < length1) { - Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1, - length1 - last); - } - Tcl_SetObjResult(interp, resultPtr); + if (last >= length1) { + last = length1; } - break; - } - case STR_TOLOWER: - case STR_TOUPPER: - case STR_TOTITLE: - if (objc < 3 || objc > 5) { - Tcl_WrongNumArgs(interp, 2, objv, "string ?first? ?last?"); - return TCL_ERROR; + if (last < first) { + Tcl_SetObjResult(interp, objv[2]); + break; } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - - if (objc == 3) { - Tcl_Obj *resultPtr = Tcl_NewStringObj(string1, length1); - if ((enum options) index == STR_TOLOWER) { - length1 = Tcl_UtfToLower(TclGetString(resultPtr)); - } else if ((enum options) index == STR_TOUPPER) { - length1 = Tcl_UtfToUpper(TclGetString(resultPtr)); - } else { - length1 = Tcl_UtfToTitle(TclGetString(resultPtr)); - } - Tcl_SetObjLength(resultPtr, length1); - Tcl_SetObjResult(interp, resultPtr); - } else { - int first, last; - CONST char *start, *end; - Tcl_Obj *resultPtr; - - length1 = Tcl_NumUtfChars(string1, length1) - 1; - if (TclGetIntForIndex(interp, objv[3], length1, - &first) != TCL_OK) { - return TCL_ERROR; - } - if (first < 0) { - first = 0; - } - last = first; - if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1, - &last) != TCL_OK)) { - return TCL_ERROR; - } - if (last >= length1) { - last = length1; - } - if (last < first) { - Tcl_SetObjResult(interp, objv[2]); - break; - } - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); - length2 = end-start; - string2 = ckalloc((size_t) length2+1); - memcpy(string2, start, (size_t) length2); - string2[length2] = '\0'; - if ((enum options) index == STR_TOLOWER) { - length2 = Tcl_UtfToLower(string2); - } else if ((enum options) index == STR_TOUPPER) { - length2 = Tcl_UtfToUpper(string2); - } else { - length2 = Tcl_UtfToTitle(string2); - } - resultPtr = Tcl_NewStringObj(string1, start - string1); - Tcl_AppendToObj(resultPtr, string2, length2); - Tcl_AppendToObj(resultPtr, end, -1); - Tcl_SetObjResult(interp, resultPtr); - ckfree(string2); - } - break; + start = Tcl_UtfAtIndex(string1, first); + end = Tcl_UtfAtIndex(start, last - first + 1); + length2 = end-start; + string2 = ckalloc((size_t) length2+1); + memcpy(string2, start, (size_t) length2); + string2[length2] = '\0'; - case STR_TRIM: { - Tcl_UniChar ch, trim; - register CONST char *p, *end; - char *check, *checkEnd; - int offset; - - left = 1; - right = 1; - - dotrim: - if (objc == 4) { - string2 = Tcl_GetStringFromObj(objv[3], &length2); - } else if (objc == 3) { - string2 = " \t\n\r"; - length2 = strlen(string2); + if ((enum options) index == STR_TOLOWER) { + length2 = Tcl_UtfToLower(string2); + } else if ((enum options) index == STR_TOUPPER) { + length2 = Tcl_UtfToUpper(string2); } else { - Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); - return TCL_ERROR; + length2 = Tcl_UtfToTitle(string2); } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - checkEnd = string2 + length2; - if (left) { - end = string1 + length1; - /* - * The outer loop iterates over the string. The inner - * loop iterates over the trim characters. The loops - * terminate as soon as a non-trim character is discovered - * and string1 is left pointing at the first non-trim - * character. - */ + resultPtr = Tcl_NewStringObj(string1, start - string1); + Tcl_AppendToObj(resultPtr, string2, length2); + Tcl_AppendToObj(resultPtr, end, -1); + Tcl_SetObjResult(interp, resultPtr); + ckfree(string2); + } + break; + + case STR_TRIMLEFT: + left = 1; + right = 0; + goto dotrim; + case STR_TRIMRIGHT: + left = 0; + right = 1; + goto dotrim; + case STR_TRIM: { + Tcl_UniChar ch, trim; + register CONST char *p, *end; + char *check, *checkEnd; + int offset; + + left = 1; + right = 1; + + dotrim: + if (objc == 4) { + string2 = Tcl_GetStringFromObj(objv[3], &length2); + } else if (objc == 3) { + string2 = " \t\n\r"; + length2 = strlen(string2); + } else { + Tcl_WrongNumArgs(interp, 2, objv, "string ?chars?"); + return TCL_ERROR; + } + string1 = Tcl_GetStringFromObj(objv[2], &length1); + checkEnd = string2 + length2; - for (p = string1; p < end; p += offset) { - offset = TclUtfToUniChar(p, &ch); - - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - string1 += offset; - break; - } - } - } - } - if (right) { - end = string1; + if (left) { + end = string1 + length1; + /* + * The outer loop iterates over the string. The inner loop + * iterates over the trim characters. The loops terminate as soon + * as a non-trim character is discovered and string1 is left + * pointing at the first non-trim character. + */ - /* - * The outer loop iterates over the string. The inner - * loop iterates over the trim characters. The loops - * terminate as soon as a non-trim character is discovered - * and length1 marks the last non-trim character. - */ + for (p = string1; p < end; p += offset) { + offset = TclUtfToUniChar(p, &ch); - for (p = string1 + length1; p > end; ) { - p = Tcl_UtfPrev(p, string1); - offset = TclUtfToUniChar(p, &ch); - for (check = string2; ; ) { - if (check >= checkEnd) { - p = end; - break; - } - check += TclUtfToUniChar(check, &trim); - if (ch == trim) { - length1 -= offset; - break; - } + for (check = string2; ; ) { + if (check >= checkEnd) { + p = end; + break; + } + check += TclUtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; + string1 += offset; + break; } } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); - break; } - case STR_TRIMLEFT: { - left = 1; - right = 0; - goto dotrim; - } - case STR_TRIMRIGHT: { - left = 0; - right = 1; - goto dotrim; - } - case STR_WORDEND: { - int cur; - Tcl_UniChar ch; - CONST char *p, *end; - int numChars; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); - return TCL_ERROR; - } + if (right) { + end = string1; - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, - &index) != TCL_OK) { - return TCL_ERROR; - } - if (index < 0) { - index = 0; - } - if (index < numChars) { - p = Tcl_UtfAtIndex(string1, index); - end = string1+length1; - for (cur = index; p < end; cur++) { - p += TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { + /* + * The outer loop iterates over the string. The inner loop + * iterates over the trim characters. The loops terminate as soon + * as a non-trim character is discovered and length1 marks the + * last non-trim character. + */ + + for (p = string1 + length1; p > end; ) { + p = Tcl_UtfPrev(p, string1); + offset = TclUtfToUniChar(p, &ch); + for (check = string2; ; ) { + if (check >= checkEnd) { + p = end; + break; + } + check += TclUtfToUniChar(check, &trim); + if (ch == trim) { + length1 -= offset; break; } } - if (cur == index) { - cur++; - } - } else { - cur = numChars; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; } - case STR_WORDSTART: { - int cur; - Tcl_UniChar ch; - CONST char *p; - int numChars; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "string index"); - return TCL_ERROR; - } + Tcl_SetObjResult(interp, Tcl_NewStringObj(string1, length1)); + break; + } + case STR_WORDEND: { + int cur; + Tcl_UniChar ch; + CONST char *p, *end; + int numChars; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } - string1 = Tcl_GetStringFromObj(objv[2], &length1); - numChars = Tcl_NumUtfChars(string1, length1); - if (TclGetIntForIndex(interp, objv[3], numChars-1, - &index) != TCL_OK) { - return TCL_ERROR; + string1 = Tcl_GetStringFromObj(objv[2], &length1); + numChars = Tcl_NumUtfChars(string1, length1); + if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index < 0) { + index = 0; + } + if (index < numChars) { + p = Tcl_UtfAtIndex(string1, index); + end = string1+length1; + for (cur = index; p < end; cur++) { + p += TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; + } } - if (index >= numChars) { - index = numChars - 1; + if (cur == index) { + cur++; } - cur = 0; - if (index > 0) { - p = Tcl_UtfAtIndex(string1, index); - for (cur = index; cur >= 0; cur--) { - TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(ch)) { - break; - } - p = Tcl_UtfPrev(p, string1); - } - if (cur != index) { - cur += 1; + } else { + cur = numChars; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + break; + } + case STR_WORDSTART: { + int cur; + Tcl_UniChar ch; + CONST char *p; + int numChars; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "string index"); + return TCL_ERROR; + } + + string1 = Tcl_GetStringFromObj(objv[2], &length1); + numChars = Tcl_NumUtfChars(string1, length1); + if (TclGetIntForIndex(interp, objv[3], numChars-1, &index) != TCL_OK) { + return TCL_ERROR; + } + if (index >= numChars) { + index = numChars - 1; + } + cur = 0; + if (index > 0) { + p = Tcl_UtfAtIndex(string1, index); + for (cur = index; cur >= 0; cur--) { + TclUtfToUniChar(p, &ch); + if (!Tcl_UniCharIsWordChar(ch)) { + break; } + p = Tcl_UtfPrev(p, string1); + } + if (cur != index) { + cur += 1; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); - break; } + Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + break; + } } return TCL_OK; } @@ -2418,9 +2468,9 @@ Tcl_StringObjCmd(dummy, interp, objc, objv) * * Tcl_SubstObjCmd -- * - * This procedure is invoked to process the "subst" Tcl command. - * See the user documentation for details on what it does. This - * command relies on Tcl_SubstObj() for its implementation. + * This procedure is invoked to process the "subst" Tcl command. See the + * user documentation for details on what it does. This command relies + * on Tcl_SubstObj() for its implementation. * * Results: * A standard Tcl result. @@ -2454,27 +2504,22 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) flags = TCL_SUBST_ALL; for (i = 1; i < (objc-1); i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, - "switch", 0, &optionIndex) != TCL_OK) { - + if (Tcl_GetIndexFromObj(interp, objv[i], substOptions, "switch", 0, + &optionIndex) != TCL_OK) { return TCL_ERROR; } switch (optionIndex) { - case SUBST_NOBACKSLASHES: { - flags &= ~TCL_SUBST_BACKSLASHES; - break; - } - case SUBST_NOCOMMANDS: { - flags &= ~TCL_SUBST_COMMANDS; - break; - } - case SUBST_NOVARS: { - flags &= ~TCL_SUBST_VARIABLES; - break; - } - default: { - Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); - } + case SUBST_NOBACKSLASHES: + flags &= ~TCL_SUBST_BACKSLASHES; + break; + case SUBST_NOCOMMANDS: + flags &= ~TCL_SUBST_COMMANDS; + break; + case SUBST_NOVARS: + flags &= ~TCL_SUBST_VARIABLES; + break; + default: + Tcl_Panic("Tcl_SubstObjCmd: bad option index to SubstOptions"); } } if (i != (objc-1)) { @@ -2486,6 +2531,7 @@ Tcl_SubstObjCmd(dummy, interp, objc, objv) /* * Perform the substitution. */ + resultPtr = Tcl_SubstObj(interp, objv[i], flags); if (resultPtr == NULL) { @@ -2520,16 +2566,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - int i, j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; + int i,j, index, mode, foundmode, result, splitObjs, numMatchesSaved, noCase; char *pattern; Tcl_Obj *stringObj, *indexVarObj, *matchVarObj; Tcl_Obj *CONST *savedObjv = objv; Tcl_RegExp regExpr = NULL; + /* - * If you add options that make -e and -g not unique prefixes of - * -exact or -glob, you *must* fix TclCompileSwitchCmd's option - * parser as well. + * If you add options that make -e and -g not unique prefixes of -exact or + * -glob, you *must* fix TclCompileSwitchCmd's option parser as well. */ + static CONST char *options[] = { "-exact", "-glob", "-indexvar", "-matchvar", "-nocase", "-regexp", "--", NULL @@ -2551,7 +2598,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (TclGetString(objv[i])[0] != '-') { break; } - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } @@ -2561,8 +2608,8 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } /* - * Check for TIP#75 options specifying the variables to write - * regexp information into. + * Check for TIP#75 options specifying the variables to write regexp + * information into. */ if (index == OPT_INDEXV) { @@ -2589,15 +2636,14 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) strCmpFn = strcasecmp; noCase = 1; } else { - if ( foundmode ) { - /* Mode already set via -exact, -glob, or -regexp */ - Tcl_AppendResult(interp, - "bad option \"", - TclGetString(objv[i]), - "\": ", - options[mode], - " option already found", - (char *) NULL); + if (foundmode) { + /* + * Mode already set via -exact, -glob, or -regexp. + */ + + Tcl_AppendResult(interp, "bad option \"", + TclGetString(objv[i]), "\": ", options[mode], + " option already found", (char *) NULL); return TCL_ERROR; } foundmode = 1; @@ -2626,8 +2672,8 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) objv += i + 1; /* - * If all of the pattern/command pairs are lumped into a single - * argument, split them out again. + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. */ splitObjs = 0; @@ -2652,8 +2698,8 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } /* - * Complain if there is an odd number of words in the list of - * patterns and bodies. + * Complain if there is an odd number of words in the list of patterns and + * bodies. */ if (objc % 2) { @@ -2661,12 +2707,11 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) Tcl_AppendResult(interp, "extra switch pattern with no body", NULL); /* - * Check if this can be due to a badly placed comment - * in the switch block. + * Check if this can be due to a badly placed comment in the switch + * block. * - * The following is an heuristic to detect the infamous - * "comment in switch" error: just check if a pattern - * begins with '#'. + * The following is an heuristic to detect the infamous "comment in + * switch" error: just check if a pattern begins with '#'. */ if (splitObjs) { @@ -2685,8 +2730,8 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) } /* - * Complain if the last body is a continuation. Note that this - * check assumes that the list is non-empty! + * Complain if the last body is a continuation. Note that this check + * assumes that the list is non-empty! */ if (strcmp(TclGetString(objv[objc-1]), "-") == 0) { @@ -2703,17 +2748,17 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) pattern = TclGetString(objv[i]); - if ((i == objc - 2) && (*pattern == 'd') + if ((i == objc - 2) && (*pattern == 'd') && (strcmp(pattern, "default") == 0)) { Tcl_Obj *emptyObj = NULL; /* - * If either indexVarObj or matchVarObj are non-NULL, - * we're in REGEXP mode but have reached the default - * clause anyway. TIP#75 specifies that we set the - * variables to empty lists (== empty objects) in that - * case. + * If either indexVarObj or matchVarObj are non-NULL, we're in + * REGEXP mode but have reached the default clause anyway. TIP#75 + * specifies that we set the variables to empty lists (== empty + * objects) in that case. */ + if (indexVarObj != NULL) { TclNewObj(emptyObj); if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, emptyObj, @@ -2770,10 +2815,9 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) matchFoundRegexp: /* - * We are operating in REGEXP mode and we need to store - * information about what we matched in some user-nominated - * arrays. So build the lists of values and indices to write - * here. [TIP#75] + * We are operating in REGEXP mode and we need to store information about + * what we matched in some user-nominated arrays. So build the lists of + * values and indices to write here. [TIP#75] */ if (numMatchesSaved) { @@ -2789,6 +2833,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (indexVarObj != NULL) { TclNewObj(indicesObj); } + for (j=0 ; j<=info.nsubs ; j++) { if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; @@ -2801,6 +2846,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) Tcl_ListObjAppendElement(NULL, indicesObj, Tcl_NewListObj(2, rangeObjAry)); } + if (matchVarObj != NULL) { Tcl_Obj *substringObj; @@ -2812,18 +2858,20 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) Tcl_ListObjAppendElement(NULL, matchesObj, substringObj); } } + if (indexVarObj != NULL) { if (Tcl_ObjSetVar2(interp, indexVarObj, NULL, indicesObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(indicesObj); + /* - * Careful! Check to see if we have allocated the - * list of matched strings; if so (but there was an - * error assigning the indices list) we have a - * potential memory leak because the match list has - * not been written to a variable. Except that we'll - * clean that up right now. + * Careful! Check to see if we have allocated the list of + * matched strings; if so (but there was an error assigning + * the indices list) we have a potential memory leak because + * the match list has not been written to a variable. Except + * that we'll clean that up right now. */ + if (matchesObj != NULL) { Tcl_DecrRefCount(matchesObj); } @@ -2834,27 +2882,29 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) if (Tcl_ObjSetVar2(interp, matchVarObj, NULL, matchesObj, TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(matchesObj); + /* - * Unlike above, if indicesObj is non-NULL at this - * point, it will have been written to a variable - * already and will hence not be leaked. + * Unlike above, if indicesObj is non-NULL at this point, it + * will have been written to a variable already and will hence + * not be leaked. */ + return TCL_ERROR; } } } - matchFound: /* - * We've got a match. Find a body to execute, skipping bodies that - * are "-". + * We've got a match. Find a body to execute, skipping bodies that are + * "-". */ + matchFound: for (j = i + 1; ; j += 2) { if (j >= objc) { /* - * This shouldn't happen since we've checked that the - * last body is not a continuation... + * This shouldn't happen since we've checked that the last body is + * not a continuation... */ Tcl_Panic("fall-out when searching for body to match pattern"); } @@ -2868,6 +2918,7 @@ Tcl_SwitchObjCmd(dummy, interp, objc, objv) /* * Generate an error message if necessary. */ + if (result == TCL_ERROR) { Tcl_Obj *msg = Tcl_NewStringObj("\n (\"", -1); Tcl_Obj *errorLine = Tcl_NewIntObj(interp->errorLine); @@ -2927,7 +2978,7 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "command ?count?"); return TCL_ERROR; } - + objPtr = objv[1]; i = count; Tcl_GetTime(&start); @@ -2938,19 +2989,30 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) } } Tcl_GetTime(&stop); - - totalMicroSec = ( ( (double) ( stop.sec - start.sec ) ) * 1.0e6 - + ( stop.usec - start.usec ) ); + + totalMicroSec = (((double) (stop.sec - start.sec))*1.0e6 + + (stop.usec - start.usec)); + if (count <= 1) { - /* Use int obj since we know time is not fractional [Bug 1202178] */ + /* + * Use int obj since we know time is not fractional. [Bug 1202178] + */ + objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); } else { objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); } + + /* + * Construct the result as a list because many programs have always parsed + * at such (extracting the first element, typically). + */ + objs[1] = Tcl_NewStringObj("microseconds", -1); objs[2] = Tcl_NewStringObj("per", -1); objs[3] = Tcl_NewStringObj("iteration", -1); Tcl_SetObjResult(interp, Tcl_NewListObj(4, objs)); + return TCL_OK; } @@ -2959,12 +3021,12 @@ Tcl_TimeObjCmd(dummy, interp, objc, objv) * * Tcl_WhileObjCmd -- * - * This procedure is invoked to process the "while" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "while" Tcl command. See the + * user documentation for details on what it does. * - * With the bytecode compiler, this procedure is only called when - * a command name is computed at runtime, and is "while" or the name - * to which "while" was renamed: e.g., "set z while; $z {$i<100} {}" + * With the bytecode compiler, this procedure is only called when a + * command name is computed at runtime, and is "while" or the name to + * which "while" was renamed: e.g., "set z while; $z {$i<100} {}" * * Results: * A standard Tcl result. @@ -3018,3 +3080,11 @@ Tcl_WhileObjCmd(dummy, interp, objc, objv) } return result; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index e378ef6..9ca9f73 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -1,4 +1,4 @@ -/* +/* * tclCompExpr.c -- * * This file contains the code to compile Tcl expressions. @@ -6,10 +6,10 @@ * Copyright (c) 1997 Sun Microsystems, Inc. * Copyright (c) 1998-2000 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.26 2005/05/10 18:34:11 kennykb Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.27 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" @@ -17,8 +17,8 @@ /* * The stuff below is a bit of a hack so that this file can be used in - * environments that include no UNIX, i.e. no errno: just arrange to use - * the errno from tclExecute.c here. + * environments that include no UNIX, i.e. no errno: just arrange to use the + * errno from tclExecute.c here. */ #ifdef TCL_GENERIC_ONLY @@ -31,8 +31,8 @@ extern int errno; /* Use errno from tclExecute.c. */ #endif /* - * Boolean variable that controls whether expression compilation tracing - * is enabled. + * Boolean variable that controls whether expression compilation tracing is + * enabled. */ #ifdef TCL_COMPILE_DEBUG @@ -40,31 +40,30 @@ static int traceExprComp = 0; #endif /* TCL_COMPILE_DEBUG */ /* - * The ExprInfo structure describes the state of compiling an expression. - * A pointer to an ExprInfo record is passed among the routines in - * this module. + * The ExprInfo structure describes the state of compiling an expression. A + * pointer to an ExprInfo record is passed among the routines in this module. */ typedef struct ExprInfo { Tcl_Interp *interp; /* Used for error reporting. */ - Tcl_Parse *parsePtr; /* Structure filled with information about - * the parsed expression. */ + Tcl_Parse *parsePtr; /* Structure filled with information about the + * parsed expression. */ CONST char *expr; /* The expression that was originally passed * to TclCompileExpr. */ CONST char *lastChar; /* Points just after last byte of expr. */ - int hasOperators; /* Set 1 if the expr has operators; 0 if - * expr is only a primary. If 1 after - * compiling an expr, a tryCvtToNumeric - * instruction is emitted to convert the - * primary to a number if possible. */ + int hasOperators; /* Set 1 if the expr has operators; 0 if expr + * is only a primary. If 1 after compiling an + * expr, a tryCvtToNumeric instruction is + * emitted to convert the primary to a number + * if possible. */ } ExprInfo; /* - * Definitions of numeric codes representing each expression operator. - * The order of these must match the entries in the operatorTable below. - * Also the codes for the relational operators (OP_LESS, OP_GREATER, - * OP_LE, OP_GE, OP_EQ, and OP_NE) must be consecutive and in that order. - * Note that OP_PLUS and OP_MINUS represent both unary and binary operators. + * Definitions of numeric codes representing each expression operator. The + * order of these must match the entries in the operatorTable below. Also the + * codes for the relational operators (OP_LESS, OP_GREATER, OP_LE, OP_GE, + * OP_EQ, and OP_NE) must be consecutive and in that order. Note that OP_PLUS + * and OP_MINUS represent both unary and binary operators. */ #define OP_MULT 0 @@ -115,7 +114,7 @@ static OperatorDesc operatorTable[] = { {"*", 2, INST_MULT}, {"/", 2, INST_DIV}, {"%", 2, INST_MOD}, - {"+", 0}, + {"+", 0}, {"-", 0}, {"<<", 2, INST_LSHIFT}, {">>", 2, INST_RSHIFT}, @@ -142,8 +141,8 @@ static OperatorDesc operatorTable[] = { }; /* - * Hashtable used to map the names of expression operators to the index - * of their OperatorDesc description. + * Hashtable used to map the names of expression operators to the index of + * their OperatorDesc description. */ static Tcl_HashTable opHashTable; @@ -176,7 +175,7 @@ static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) \ if (traceExprComp) { \ fprintf(stderr, "CompileSubExpr: \"%.*s\", token \"%.*s\"\n", \ - (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ + (exprLength), (exprBytes), (tokenLength), (tokenBytes)); \ } #else #define TRACE(exprBytes, exprLength, tokenBytes, tokenLength) @@ -187,11 +186,11 @@ static void LogSyntaxError _ANSI_ARGS_((ExprInfo *infoPtr)); * * TclCompileExpr -- * - * This procedure compiles a string containing a Tcl expression into - * Tcl bytecodes. This procedure is the top-level interface to the - * the expression compilation module, and is used by such public - * procedures as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, - * Tcl_ExprDouble, Tcl_ExprBoolean, and Tcl_ExprBooleanObj. + * This procedure compiles a string containing a Tcl expression into Tcl + * bytecodes. This procedure is the top-level interface to the the + * expression compilation module, and is used by such public procedures + * as Tcl_ExprString, Tcl_ExprStringObj, Tcl_ExprLong, Tcl_ExprDouble, + * Tcl_ExprBoolean, and Tcl_ExprBooleanObj. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR @@ -219,8 +218,8 @@ TclCompileExpr(interp, script, numBytes, envPtr) int new, i, code; /* - * If this is the first time we've been called, initialize the table - * of expression operators. + * If this is the first time we've been called, initialize the table of + * expression operators. */ if (numBytes < 0) { @@ -243,14 +242,14 @@ TclCompileExpr(interp, script, numBytes, envPtr) } /* - * Initialize the structure containing information abvout this - * expression compilation. + * Initialize the structure containing information abvout this expression + * compilation. */ info.interp = interp; info.parsePtr = &parse; info.expr = script; - info.lastChar = (script + numBytes); + info.lastChar = (script + numBytes); info.hasOperators = 0; /* @@ -267,20 +266,19 @@ TclCompileExpr(interp, script, numBytes, envPtr) Tcl_FreeParse(&parse); goto done; } - + if (!info.hasOperators) { /* - * Attempt to convert the primary's object to an int or double. - * This is done in order to support Tcl's policy of interpreting - * operands if at all possible as first integers, else - * floating-point numbers. + * Attempt to convert the primary's object to an int or double. This + * is done in order to support Tcl's policy of interpreting operands + * if at all possible as first integers, else floating-point numbers. */ - + TclEmitOpcode(INST_TRY_CVT_TO_NUMERIC, envPtr); } Tcl_FreeParse(&parse); - done: + done: return code; } @@ -289,17 +287,16 @@ TclCompileExpr(interp, script, numBytes, envPtr) * * TclFinalizeCompilation -- * - * Clean up the compilation environment so it can later be - * properly reinitialized. This procedure is called by - * TclFinalizeCompExecEnv() in tclObj.c, which in turn is called - * by Tcl_Finalize(). + * Clean up the compilation environment so it can later be properly + * reinitialized. This procedure is called by TclFinalizeCompExecEnv() in + * tclObj.c, which in turn is called by Tcl_Finalize(). * * Results: * None. * * Side effects: - * Cleans up the compilation environment. At the moment, just the - * table of expression operators is freed. + * Cleans up the compilation environment. At the moment, just the table + * of expression operators is freed. * *---------------------------------------------------------------------- */ @@ -309,8 +306,8 @@ TclFinalizeCompilation() { Tcl_MutexLock(&opMutex); if (opTableInitialized) { - Tcl_DeleteHashTable(&opHashTable); - opTableInitialized = 0; + Tcl_DeleteHashTable(&opHashTable); + opTableInitialized = 0; } Tcl_MutexUnlock(&opMutex); } @@ -337,8 +334,8 @@ TclFinalizeCompilation() static int CompileSubExpr(exprTokenPtr, infoPtr, envPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * to compile. */ + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token to + * compile. */ ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ @@ -354,7 +351,7 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) if (exprTokenPtr->type != TCL_TOKEN_SUB_EXPR) { Tcl_Panic("CompileSubExpr: token type %d not TCL_TOKEN_SUB_EXPR\n", - exprTokenPtr->type); + exprTokenPtr->type); } code = TCL_OK; @@ -363,192 +360,184 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) * After processing it, advance tokenPtr to point just after the * subexpression's last token. */ - + tokenPtr = exprTokenPtr+1; TRACE(exprTokenPtr->start, exprTokenPtr->size, tokenPtr->start, tokenPtr->size); switch (tokenPtr->type) { - case TCL_TOKEN_WORD: - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_TEXT: - if (tokenPtr->size > 0) { - objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, - tokenPtr->size); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); + case TCL_TOKEN_WORD: + TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr); + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_TEXT: + if (tokenPtr->size > 0) { + objIndex = TclRegisterNewLiteral(envPtr, tokenPtr->start, + tokenPtr->size); + } else { + objIndex = TclRegisterNewLiteral(envPtr, "", 0); + } + TclEmitPush(objIndex, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); + if (length > 0) { + objIndex = TclRegisterNewLiteral(envPtr, buffer, length); + } else { + objIndex = TclRegisterNewLiteral(envPtr, "", 0); + } + TclEmitPush(objIndex, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_COMMAND: + TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + tokenPtr += 1; + break; + + case TCL_TOKEN_VARIABLE: + TclCompileTokens(interp, tokenPtr, 1, envPtr); + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_SUB_EXPR: + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + break; + + case TCL_TOKEN_OPERATOR: + /* + * Look up the operator. If the operator isn't found, treat it as a + * math function. + */ + Tcl_DStringInit(&opBuf); + operator = Tcl_DStringAppend(&opBuf, tokenPtr->start, tokenPtr->size); + hPtr = Tcl_FindHashEntry(&opHashTable, operator); + if (hPtr == NULL) { + code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, envPtr, + &endPtr); + Tcl_DStringFree(&opBuf); + if (code != TCL_OK) { + goto done; } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; + tokenPtr = endPtr; break; - - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, - buffer); - if (length > 0) { - objIndex = TclRegisterNewLiteral(envPtr, buffer, length); - } else { - objIndex = TclRegisterNewLiteral(envPtr, "", 0); + } + Tcl_DStringFree(&opBuf); + opIndex = (int) Tcl_GetHashValue(hPtr); + opDescPtr = &(operatorTable[opIndex]); + + /* + * If the operator is "normal", compile it using information from the + * operator table. + */ + + if (opDescPtr->numOperands > 0) { + tokenPtr++; + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; } - TclEmitPush(objIndex, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_COMMAND: - TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, envPtr); - tokenPtr += 1; - break; - - case TCL_TOKEN_VARIABLE: - TclCompileTokens(interp, tokenPtr, 1, envPtr); tokenPtr += (tokenPtr->numComponents + 1); + + if (opDescPtr->numOperands == 2) { + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + } + TclEmitOpcode(opDescPtr->instruction, envPtr); + infoPtr->hasOperators = 1; break; - - case TCL_TOKEN_SUB_EXPR: + } + + /* + * The operator requires special treatment, and is either "+" or "-", + * or one of "&&", "||" or "?". + */ + + switch (opIndex) { + case OP_PLUS: + case OP_MINUS: + tokenPtr++; code = CompileSubExpr(tokenPtr, infoPtr, envPtr); if (code != TCL_OK) { goto done; } tokenPtr += (tokenPtr->numComponents + 1); - break; - - case TCL_TOKEN_OPERATOR: + /* - * Look up the operator. If the operator isn't found, treat it - * as a math function. + * Check whether the "+" or "-" is unary. */ - Tcl_DStringInit(&opBuf); - operator = Tcl_DStringAppend(&opBuf, - tokenPtr->start, tokenPtr->size); - hPtr = Tcl_FindHashEntry(&opHashTable, operator); - if (hPtr == NULL) { - code = CompileMathFuncCall(exprTokenPtr, operator, infoPtr, - envPtr, &endPtr); - Tcl_DStringFree(&opBuf); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; + + afterSubexprPtr = exprTokenPtr + exprTokenPtr->numComponents+1; + if (tokenPtr == afterSubexprPtr) { + TclEmitOpcode(((opIndex==OP_PLUS)? INST_UPLUS : INST_UMINUS), + envPtr); break; } - Tcl_DStringFree(&opBuf); - opIndex = (int) Tcl_GetHashValue(hPtr); - opDescPtr = &(operatorTable[opIndex]); /* - * If the operator is "normal", compile it using information - * from the operator table. + * The "+" or "-" is binary. */ - if (opDescPtr->numOperands > 0) { - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); + code = CompileSubExpr(tokenPtr, infoPtr, envPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr += (tokenPtr->numComponents + 1); + TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), envPtr); + break; - if (opDescPtr->numOperands == 2) { - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - } - TclEmitOpcode(opDescPtr->instruction, envPtr); - infoPtr->hasOperators = 1; - break; + case OP_LAND: + case OP_LOR: + code = CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, + &endPtr); + if (code != TCL_OK) { + goto done; } - - /* - * The operator requires special treatment, and is either - * "+" or "-", or one of "&&", "||" or "?". - */ - - switch (opIndex) { - case OP_PLUS: - case OP_MINUS: - tokenPtr++; - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - - /* - * Check whether the "+" or "-" is unary. - */ - - afterSubexprPtr = exprTokenPtr - + exprTokenPtr->numComponents+1; - if (tokenPtr == afterSubexprPtr) { - TclEmitOpcode(((opIndex==OP_PLUS)? - INST_UPLUS : INST_UMINUS), - envPtr); - break; - } - - /* - * The "+" or "-" is binary. - */ - - code = CompileSubExpr(tokenPtr, infoPtr, envPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr += (tokenPtr->numComponents + 1); - TclEmitOpcode(((opIndex==OP_PLUS)? INST_ADD : INST_SUB), - envPtr); - break; - - case OP_LAND: - case OP_LOR: - code = CompileLandOrLorExpr(exprTokenPtr, opIndex, - infoPtr, envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - case OP_QUESTY: - code = CompileCondExpr(exprTokenPtr, infoPtr, - envPtr, &endPtr); - if (code != TCL_OK) { - goto done; - } - tokenPtr = endPtr; - break; - - default: - Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", - opIndex); - } /* end switch on operator requiring special treatment */ - infoPtr->hasOperators = 1; + tokenPtr = endPtr; + break; + + case OP_QUESTY: + code = CompileCondExpr(exprTokenPtr, infoPtr, envPtr, &endPtr); + if (code != TCL_OK) { + goto done; + } + tokenPtr = endPtr; break; - default: - Tcl_Panic("CompileSubExpr: unexpected token type %d\n", - tokenPtr->type); + default: + Tcl_Panic("CompileSubExpr: unexpected operator %d requiring special treatment\n", + opIndex); + } /* end switch on operator requiring special treatment */ + infoPtr->hasOperators = 1; + break; + + default: + Tcl_Panic("CompileSubExpr: unexpected token type %d\n", + tokenPtr->type); } /* * Verify that the subexpression token had the required number of - * subtokens: that we've advanced tokenPtr just beyond the - * subexpression's last token. For example, a "*" subexpression must - * contain the tokens for exactly two operands. + * subtokens: that we've advanced tokenPtr just beyond the subexpression's + * last token. For example, a "*" subexpression must contain the tokens + * for exactly two operands. */ - + if (tokenPtr != (exprTokenPtr + exprTokenPtr->numComponents+1)) { LogSyntaxError(infoPtr); code = TCL_ERROR; } - - done: + + done: return code; } @@ -557,8 +546,8 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) * * CompileLandOrLorExpr -- * - * This procedure compiles a Tcl logical and ("&&") or logical or - * ("||") subexpression. + * This procedure compiles a Tcl logical and ("&&") or logical or ("||") + * subexpression. * * Results: * The return value is TCL_OK on a successful compilation and TCL_ERROR @@ -575,22 +564,23 @@ CompileSubExpr(exprTokenPtr, infoPtr, envPtr) static int CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) - Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token - * containing the "&&" or "||" operator. */ - int opIndex; /* A code describing the expression - * operator: either OP_LAND or OP_LOR. */ - ExprInfo *infoPtr; /* Describes the compilation state for the - * expression being compiled. */ - CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ + Tcl_Token *exprTokenPtr; /* Points to TCL_TOKEN_SUB_EXPR token + * containing the "&&" or "||" operator. */ + int opIndex; /* A code describing the expression operator: + * either OP_LAND or OP_LOR. */ + ExprInfo *infoPtr; /* Describes the compilation state for the + * expression being compiled. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ { - JumpFixup shortCircuitFixup; /* Used to fix up the short circuit jump - * after the first subexpression. */ - JumpFixup shortCircuitFixup2;/* Used to fix up the second jump to the - * short-circuit target. */ - JumpFixup endFixup; /* Used to fix up jump to the end. */ + JumpFixup shortCircuitFixup;/* Used to fix up the short circuit jump after + * the first subexpression. */ + JumpFixup shortCircuitFixup2; + /* Used to fix up the second jump to the + * short-circuit target. */ + JumpFixup endFixup; /* Used to fix up jump to the end. */ Tcl_Token *tokenPtr; int code; int savedStackDepth = envPtr->currStackDepth; @@ -623,11 +613,11 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) goto done; } tokenPtr += (tokenPtr->numComponents + 1); - + /* - * The result is the boolean value of the second operand. We - * code this in a somewhat contorted manner to be able to reuse - * the shortCircuit value and save one INST_JUMP. + * The result is the boolean value of the second operand. We code this in + * a somewhat contorted manner to be able to reuse the shortCircuit value + * and save one INST_JUMP. */ TclEmitForwardJump(envPtr, @@ -642,8 +632,8 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &endFixup); /* - * Fixup the short-circuit jumps and push the shortCircuit value. - * Note that shortCircuitFixup2 is always a short jump. + * Fixup the short-circuit jumps and push the shortCircuit value. Note + * that shortCircuitFixup2 is always a short jump. */ TclFixupForwardJumpToHere(envPtr, &shortCircuitFixup2, 127); @@ -651,7 +641,7 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) /* * shortCircuit jump grown by 3 bytes: update endFixup. */ - + endFixup.codeOffset += 3; } @@ -664,7 +654,7 @@ CompileLandOrLorExpr(exprTokenPtr, opIndex, infoPtr, envPtr, endPtrPtr) TclFixupForwardJumpToHere(envPtr, &endFixup, 127); *endPtrPtr = tokenPtr; - done: + done: envPtr->currStackDepth = savedStackDepth + 1; return code; } @@ -697,9 +687,9 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ { JumpFixup jumpAroundThenFixup, jumpAroundElseFixup; /* Used to update or replace one-byte jumps @@ -719,18 +709,18 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) goto done; } tokenPtr += (tokenPtr->numComponents + 1); - + /* * Emit the jump to the "else" expression if the test was false. */ - + TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpAroundThenFixup); /* - * Compile the "then" expression. Note that if a subexpression is only - * a primary, we need to try to convert it to numeric. We do this to - * support Tcl's policy of interpreting operands if at all possible as - * first integers, else floating-point numbers. + * Compile the "then" expression. Note that if a subexpression is only a + * primary, we need to try to convert it to numeric. We do this to support + * Tcl's policy of interpreting operands if at all possible as first + * integers, else floating-point numbers. */ infoPtr->hasOperators = 0; @@ -746,9 +736,8 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) /* * Emit an unconditional jump around the "else" condExpr. */ - - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpAroundElseFixup); + + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpAroundElseFixup); /* * Compile the "else" expression. @@ -774,22 +763,22 @@ CompileCondExpr(exprTokenPtr, infoPtr, envPtr, endPtrPtr) - jumpAroundElseFixup.codeOffset; if (TclFixupForwardJump(envPtr, &jumpAroundElseFixup, dist, 127)) { /* - * Update the else expression's starting code offset since it - * moved down 3 bytes too. + * Update the else expression's starting code offset since it moved + * down 3 bytes too. */ - + elseCodeOffset += 3; } - + /* * Fix up the first jump to the "else" expression if the test was false. */ - + dist = (elseCodeOffset - jumpAroundThenFixup.codeOffset); TclFixupForwardJump(envPtr, &jumpAroundThenFixup, dist, 127); *endPtrPtr = tokenPtr; - done: + done: envPtr->currStackDepth = savedStackDepth + 1; return code; } @@ -824,31 +813,30 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) ExprInfo *infoPtr; /* Describes the compilation state for the * expression being compiled. */ CompileEnv *envPtr; /* Holds resulting instructions. */ - Tcl_Token **endPtrPtr; /* If successful, a pointer to the token - * just after the last token in the - * subexpression is stored here. */ + Tcl_Token **endPtrPtr; /* If successful, a pointer to the token just + * after the last token in the subexpression + * is stored here. */ { Tcl_DString cmdName; int objIndex; Tcl_Token *tokenPtr, *afterSubexprPtr; int argCount; int code = TCL_OK; - + /* - * Prepend "tcl::mathfunc::" to the function name, to produce the - * name of a command that evaluates the function. Push that - * command name on the stack, in a literal registered to the - * namespace so that resolution can be cached. + * Prepend "tcl::mathfunc::" to the function name, to produce the name of + * a command that evaluates the function. Push that command name on the + * stack, in a literal registered to the namespace so that resolution can + * be cached. */ - Tcl_DStringInit( &cmdName ); - Tcl_DStringAppend( &cmdName, "tcl::mathfunc::", -1 ); - Tcl_DStringAppend( &cmdName, funcName, -1 ); - objIndex = TclRegisterNewNSLiteral( envPtr, - Tcl_DStringValue( &cmdName ), - Tcl_DStringLength( &cmdName ) ); - TclEmitPush( objIndex, envPtr ); - Tcl_DStringFree( &cmdName ); + Tcl_DStringInit(&cmdName); + Tcl_DStringAppend(&cmdName, "tcl::mathfunc::", -1); + Tcl_DStringAppend(&cmdName, funcName, -1); + objIndex = TclRegisterNewNSLiteral(envPtr, Tcl_DStringValue(&cmdName), + Tcl_DStringLength(&cmdName)); + TclEmitPush(objIndex, envPtr); + Tcl_DStringFree(&cmdName); /* * Compile any arguments for the function. @@ -865,13 +853,13 @@ CompileMathFuncCall(exprTokenPtr, funcName, infoPtr, envPtr, endPtrPtr) } tokenPtr += (tokenPtr->numComponents + 1); } - + /* Invoke the function */ - if ( argCount < 255 ) { - TclEmitInstInt1( INST_INVOKE_STK1, argCount, envPtr ); + if (argCount < 255) { + TclEmitInstInt1(INST_INVOKE_STK1, argCount, envPtr); } else { - TclEmitInstInt4( INST_INVOKE_STK4, argCount, envPtr ); + TclEmitInstInt4(INST_INVOKE_STK4, argCount, envPtr); } *endPtrPtr = afterSubexprPtr; @@ -903,9 +891,17 @@ LogSyntaxError(infoPtr) * expression being compiled. */ { Tcl_Obj *result = - Tcl_NewStringObj("syntax error in expression \"", -1); + Tcl_NewStringObj("syntax error in expression \"", -1); TclAppendLimitedToObj(result, infoPtr->expr, - (int)(infoPtr->lastChar - infoPtr->expr), 60, ""); + (int)(infoPtr->lastChar - infoPtr->expr), 60, ""); Tcl_AppendToObj(result, "\"", -1); Tcl_SetObjResult(infoPtr->interp, result); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 646713d..8108771 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEncoding.c,v 1.35 2005/05/10 18:34:34 kennykb Exp $ + * RCS: @(#) $Id: tclEncoding.c,v 1.36 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" @@ -16,8 +16,8 @@ typedef size_t (LengthProc)_ANSI_ARGS_((CONST char *src)); /* - * The following data structure represents an encoding, which describes how - * to convert between various character sets and UTF-8. + * The following data structure represents an encoding, which describes how to + * convert between various character sets and UTF-8. */ typedef struct Encoding { @@ -28,8 +28,8 @@ typedef struct Encoding { * Tcl_EncodingType structure may not be * persistent. */ Tcl_EncodingConvertProc *toUtfProc; - /* Procedure to convert from external - * encoding into UTF-8. */ + /* Procedure to convert from external encoding + * into UTF-8. */ Tcl_EncodingConvertProc *fromUtfProc; /* Procedure to convert from UTF-8 into * external encoding. */ @@ -61,9 +61,9 @@ typedef struct Encoding { */ typedef struct TableEncodingData { - int fallback; /* Character (in this encoding) to - * substitute when this encoding cannot - * represent a UTF-8 character. */ + int fallback; /* Character (in this encoding) to substitute + * when this encoding cannot represent a UTF-8 + * character. */ char prefixBytes[256]; /* If a byte in the input stream is a lead * byte for a 2-byte sequence, the * corresponding entry in this array is 1, @@ -73,7 +73,8 @@ typedef struct TableEncodingData { * Each element of the toUnicode array points * to an array of 256 shorts. If there is no * corresponding character in Unicode, the - * value in the matrix is 0x0000. malloc'd. */ + * value in the matrix is 0x0000. + * malloc'd. */ unsigned short **fromUnicode; /* Two dimensional sparse matrix to map * characters from Unicode to the encoding. @@ -86,11 +87,11 @@ typedef struct TableEncodingData { /* * The following structures is the clientData for a dynamically-loaded, - * escape-driven encoding that is itself comprised of other simpler - * encodings. An example is "iso-2022-jp", which uses escape sequences to - * switch between ascii, jis0208, jis0212, gb2312, and ksc5601. Note that - * "escape-driven" does not necessarily mean that the ESCAPE character is - * the character used for switching character sets. + * escape-driven encoding that is itself comprised of other simpler encodings. + * An example is "iso-2022-jp", which uses escape sequences to switch between + * ascii, jis0208, jis0212, gb2312, and ksc5601. Note that "escape-driven" + * does not necessarily mean that the ESCAPE character is the character used + * for switching character sets. */ typedef struct EscapeSubTable { @@ -103,25 +104,25 @@ typedef struct EscapeSubTable { } EscapeSubTable; typedef struct EscapeEncodingData { - int fallback; /* Character (in this encoding) to - * substitute when this encoding cannot - * represent a UTF-8 character. */ + int fallback; /* Character (in this encoding) to substitute + * when this encoding cannot represent a UTF-8 + * character. */ unsigned int initLen; /* Length of following string. */ char init[16]; /* String to emit or expect before first char * in conversion. */ unsigned int finalLen; /* Length of following string. */ - char final[16]; /* String to emit or expect after last char - * in conversion. */ - char prefixBytes[256]; /* If a byte in the input stream is the - * first character of one of the escape - * sequences in the following array, the - * corresponding entry in this array is 1, - * otherwise it is 0. */ + char final[16]; /* String to emit or expect after last char in + * conversion. */ + char prefixBytes[256]; /* If a byte in the input stream is the first + * character of one of the escape sequences in + * the following array, the corresponding + * entry in this array is 1, otherwise it is + * 0. */ int numSubTables; /* Length of following array. */ - EscapeSubTable subTables[1];/* Information about each EscapeSubTable - * used by this encoding type. The actual - * size will be as large as necessary to - * hold all EscapeSubTables. */ + EscapeSubTable subTables[1];/* Information about each EscapeSubTable used + * by this encoding type. The actual size + * will be as large as necessary to hold all + * EscapeSubTables. */ } EscapeEncodingData; /* @@ -135,49 +136,51 @@ typedef struct EscapeEncodingData { #define ENCODING_ESCAPE 3 /* - * A list of directories in which Tcl should look for *.enc files. - * This list is shared by all threads. Access is governed by a - * mutex lock. + * A list of directories in which Tcl should look for *.enc files. This list + * is shared by all threads. Access is governed by a mutex lock. */ -static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; -static ProcessGlobalValue encodingSearchPath = - {0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL}; +static TclInitProcessGlobalValueProc InitializeEncodingSearchPath; +static ProcessGlobalValue encodingSearchPath = { + 0, 0, NULL, NULL, InitializeEncodingSearchPath, NULL, NULL +}; /* - * A map from encoding names to the directories in which their data - * files have been seen. The string value of the map is shared by all - * threads. Access to the shared string is governed by a mutex lock. + * A map from encoding names to the directories in which their data files have + * been seen. The string value of the map is shared by all threads. Access + * to the shared string is governed by a mutex lock. */ -static ProcessGlobalValue encodingFileMap = - {0, 0, NULL, NULL, NULL, NULL, NULL}; +static ProcessGlobalValue encodingFileMap = { + 0, 0, NULL, NULL, NULL, NULL, NULL +}; /* - * A list of directories making up the "library path". Historically - * this search path has served many uses, but the only one remaining - * is a base for the encodingSearchPath above. If the application - * does not explicitly set the encodingSearchPath, then it will be - * initialized by appending /encoding to each directory in this - * "libraryPath". + * A list of directories making up the "library path". Historically this + * search path has served many uses, but the only one remaining is a base for + * the encodingSearchPath above. If the application does not explicitly set + * the encodingSearchPath, then it will be initialized by appending /encoding + * to each directory in this "libraryPath". */ -static ProcessGlobalValue libraryPath = - {0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL}; + +static ProcessGlobalValue libraryPath = { + 0, 0, NULL, NULL, TclpInitLibraryPath, NULL, NULL +}; static int encodingsInitialized = 0; /* - * Hash table that keeps track of all loaded Encodings. Keys are - * the string names that represent the encoding, values are (Encoding *). + * Hash table that keeps track of all loaded Encodings. Keys are the string + * names that represent the encoding, values are (Encoding *). */ - + static Tcl_HashTable encodingTable; TCL_DECLARE_MUTEX(encodingMutex) /* - * The following are used to hold the default and current system encodings. - * If NULL is passed to one of the conversion routines, the current setting - * of the system encoding will be used to perform the conversion. + * The following are used to hold the default and current system encodings. + * If NULL is passed to one of the conversion routines, the current setting of + * the system encoding will be used to perform the conversion. */ static Tcl_Encoding defaultEncoding; @@ -221,10 +224,10 @@ static Tcl_Encoding LoadEncodingFile _ANSI_ARGS_((Tcl_Interp *interp, CONST char *name)); static Tcl_Encoding LoadTableEncoding _ANSI_ARGS_((CONST char *name, int type, Tcl_Channel chan)); -static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, +static Tcl_Encoding LoadEscapeEncoding _ANSI_ARGS_((CONST char *name, Tcl_Channel chan)); -static Tcl_Channel OpenEncodingFileChannel _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *name)); +static Tcl_Channel OpenEncodingFileChannel _ANSI_ARGS_(( + Tcl_Interp *interp, CONST char *name)); static void TableFreeProc _ANSI_ARGS_((ClientData clientData)); static int TableFromUtfProc _ANSI_ARGS_((ClientData clientData, CONST char *src, int srcLen, int flags, @@ -264,35 +267,35 @@ static int UtfExtToUtfIntProc _ANSI_ARGS_((ClientData clientData, int *dstCharsPtr)); /* - * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep. - * This should help the lifetime of encodings be more useful. - * See concerns raised in [Bug 1077262]. + * A Tcl_ObjType for holding a cached Tcl_Encoding as the intrep. This should + * help the lifetime of encodings be more useful. See concerns raised in [Bug + * 1077262]. */ static Tcl_ObjType EncodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; - /* *---------------------------------------------------------------------- * * TclGetEncodingFromObj -- * - * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), - * if possible, and returns TCL_OK. If no such encoding exists, - * TCL_ERROR is returned, and if interp is non-NULL, an error message - * is written there. + * Writes to (*encodingPtr) the Tcl_Encoding value of (*objPtr), if + * possible, and returns TCL_OK. If no such encoding exists, TCL_ERROR + * is returned, and if interp is non-NULL, an error message is written + * there. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: * Caches the Tcl_Encoding value as the internal rep of (*objPtr). * *---------------------------------------------------------------------- */ -int + +int TclGetEncodingFromObj(interp, objPtr, encodingPtr) Tcl_Interp *interp; Tcl_Obj *objPtr; @@ -318,10 +321,11 @@ TclGetEncodingFromObj(interp, objPtr, encodingPtr) * * FreeEncodingIntRep -- * - * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. + * The Tcl_FreeInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ + static void FreeEncodingIntRep(objPtr) Tcl_Obj *objPtr; @@ -334,10 +338,11 @@ FreeEncodingIntRep(objPtr) * * DupEncodingIntRep -- * - * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. + * The Tcl_DupInternalRepProc for the "encoding" Tcl_ObjType. * *---------------------------------------------------------------------- */ + static void DupEncodingIntRep(srcPtr, dupPtr) Tcl_Obj *srcPtr; @@ -352,12 +357,11 @@ DupEncodingIntRep(srcPtr, dupPtr) * * TclGetEncodingSearchPath -- * - * Keeps the per-thread copy of the encoding search path current - * with changes to the global copy. + * Keeps the per-thread copy of the encoding search path current with + * changes to the global copy. * * Results: - * Returns a "list" (Tcl_Obj *) that contains the encoding - * search path. + * Returns a "list" (Tcl_Obj *) that contains the encoding search path. * *---------------------------------------------------------------------- */ @@ -372,15 +376,15 @@ TclGetEncodingSearchPath() { * * TclSetEncodingSearchPath -- * - * Keeps the per-thread copy of the encoding search path current - * with changes to the global copy. + * Keeps the per-thread copy of the encoding search path current with + * changes to the global copy. * *---------------------------------------------------------------------- */ -int +int TclSetEncodingSearchPath(searchPath) - Tcl_Obj *searchPath; + Tcl_Obj *searchPath; { int dummy; @@ -396,11 +400,11 @@ TclSetEncodingSearchPath(searchPath) * * TclGetLibraryPath -- * - * Keeps the per-thread copy of the library path current - * with changes to the global copy. + * Keeps the per-thread copy of the library path current with changes to + * the global copy. * * Results: - * Returns a "list" (Tcl_Obj *) that contains the library path. + * Returns a "list" (Tcl_Obj *) that contains the library path. * *---------------------------------------------------------------------- */ @@ -415,19 +419,19 @@ TclGetLibraryPath() { * * TclSetLibraryPath -- * - * Keeps the per-thread copy of the library path current - * with changes to the global copy. + * Keeps the per-thread copy of the library path current with changes to + * the global copy. * - * NOTE: this routine returns void, so there's no way to - * report the error that searchPath is not a valid list. - * In that case, this routine will silently do nothing. + * NOTE: this routine returns void, so there's no way to report the error + * that searchPath is not a valid list. In that case, this routine will + * silently do nothing. * *---------------------------------------------------------------------- */ void TclSetLibraryPath(path) - Tcl_Obj *path; + Tcl_Obj *path; { int dummy; @@ -442,18 +446,17 @@ TclSetLibraryPath(path) * * FillEncodingFileMap -- * - * Called to bring the encoding file map in sync with the current - * value of the encoding search path. + * Called to bring the encoding file map in sync with the current value + * of the encoding search path. * - * Scan the directories on the encoding search path, find the - * *.enc files, and store the found pathnames in a map associated - * with the encoding name. + * Scan the directories on the encoding search path, find the *.enc + * files, and store the found pathnames in a map associated with the + * encoding name. * - * In particular, if $dir is on the encoding search path, and the - * file $dir/foo.enc is found, then store a "foo" -> $dir entry - * in the map. Later, any need for the "foo" encoding will quickly - * be able to construct the $dir/foo.enc pathname for reading the - * encoding data. + * In particular, if $dir is on the encoding search path, and the file + * $dir/foo.enc is found, then store a "foo" -> $dir entry in the map. + * Later, any need for the "foo" encoding will quickly * be able to + * construct the $dir/foo.enc pathname for reading the encoding data. * * Results: * None. @@ -475,23 +478,25 @@ FillEncodingFileMap() Tcl_ListObjLength(NULL, searchPath, &numDirs); map = Tcl_NewDictObj(); Tcl_IncrRefCount(map); + for (i = numDirs-1; i >= 0; i--) { - /* - * Iterate backwards through the search path so as we - * overwrite entries found, we favor files earlier on - * the search path. + /* + * Iterate backwards through the search path so as we overwrite + * entries found, we favor files earlier on the search path. */ + int j, numFiles; Tcl_Obj *directory, *matchFileList = Tcl_NewObj(); Tcl_Obj **filev; - Tcl_GlobTypeData readableFiles = - {TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL}; + Tcl_GlobTypeData readableFiles = { + TCL_GLOB_TYPE_FILE, TCL_GLOB_PERM_R, NULL, NULL + }; Tcl_ListObjIndex(NULL, searchPath, i, &directory); Tcl_IncrRefCount(directory); Tcl_IncrRefCount(matchFileList); - Tcl_FSMatchInDirectory(NULL, matchFileList, - directory, "*.enc", &readableFiles); + Tcl_FSMatchInDirectory(NULL, matchFileList, directory, "*.enc", + &readableFiles); Tcl_ListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; jname; + + return ((Encoding *) encoding)->name; } /* @@ -833,8 +840,8 @@ Tcl_GetEncodingName(encoding) * * Tcl_GetEncodingNames -- * - * Get the list of all known encodings, including the ones stored - * as files on disk in the encoding path. + * Get the list of all known encodings, including the ones stored as + * files on disk in the encoding path. * * Results: * Modifies interp's result object to hold a list of all the available @@ -859,7 +866,10 @@ Tcl_GetEncodingNames(interp) Tcl_InitObjHashTable(&table); - /* Copy encoding names from loaded encoding table to table */ + /* + * Copy encoding names from loaded encoding table to table. + */ + Tcl_MutexLock(&encodingMutex); for (hPtr = Tcl_FirstHashEntry(&encodingTable, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { @@ -872,16 +882,22 @@ Tcl_GetEncodingNames(interp) FillEncodingFileMap(); map = TclGetProcessGlobalValue(&encodingFileMap); - /* Copy encoding names from encoding file map to table */ + /* + * Copy encoding names from encoding file map to table. + */ + Tcl_DictObjFirst(NULL, map, &mapSearch, &name, NULL, &done); for (; !done; Tcl_DictObjNext(&mapSearch, &name, NULL, &done)) { Tcl_CreateHashEntry(&table, (char *) name, &dummy); } - /* Pull all encoding names from table into the result list */ + /* + * Pull all encoding names from table into the result list. + */ + for (hPtr = Tcl_FirstHashEntry(&table, &search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { - Tcl_ListObjAppendElement(NULL, result, + Tcl_ListObjAppendElement(NULL, result, (Tcl_Obj *) Tcl_GetHashKey(&table, hPtr)); } Tcl_SetObjResult(interp, result); @@ -893,21 +909,21 @@ Tcl_GetEncodingNames(interp) * * Tcl_SetSystemEncoding -- * - * Sets the default encoding that should be used whenever the user - * passes a NULL value in to one of the conversion routines. - * If the supplied name is NULL, the system encoding is reset to the - * default system encoding. + * Sets the default encoding that should be used whenever the user passes + * a NULL value in to one of the conversion routines. If the supplied + * name is NULL, the system encoding is reset to the default system + * encoding. * * Results: - * The return value is TCL_OK if the system encoding was successfully - * set to the encoding specified by name, TCL_ERROR otherwise. If - * TCL_ERROR is returned, an error message is left in interp's result - * object, unless interp was NULL. + * The return value is TCL_OK if the system encoding was successfully set + * to the encoding specified by name, TCL_ERROR otherwise. If TCL_ERROR + * is returned, an error message is left in interp's result object, + * unless interp was NULL. * * Side effects: - * The reference count of the new system encoding is incremented. - * The reference count of the old system encoding is decremented and - * it may be freed. + * The reference count of the new system encoding is incremented. The + * reference count of the old system encoding is decremented and it may + * be freed. * *------------------------------------------------------------------------ */ @@ -948,25 +964,25 @@ Tcl_SetSystemEncoding(interp, name) * Tcl_CreateEncoding -- * * This procedure is called to define a new encoding and the procedures - * that are used to convert between the specified encoding and Unicode. + * that are used to convert between the specified encoding and Unicode. * * Results: - * Returns a token that represents the encoding. If an encoding with - * the same name already existed, the old encoding token remains - * valid and continues to behave as it used to, and will eventually - * be garbage collected when the last reference to it goes away. Any - * subsequent calls to Tcl_GetEncoding with the specified name will - * retrieve the most recent encoding token. + * Returns a token that represents the encoding. If an encoding with the + * same name already existed, the old encoding token remains valid and + * continues to behave as it used to, and will eventually be garbage + * collected when the last reference to it goes away. Any subsequent + * calls to Tcl_GetEncoding with the specified name will retrieve the + * most recent encoding token. * * Side effects: * The new encoding type is entered into a table visible to all - * interpreters, keyed off the encoding's name. For each call to - * this procedure, there should eventually be a call to - * Tcl_FreeEncoding, so that the database can be cleaned up when - * encodings aren't needed anymore. + * interpreters, keyed off the encoding's name. For each call to this + * procedure, there should eventually be a call to Tcl_FreeEncoding, so + * that the database can be cleaned up when encodings aren't needed + * anymore. * *--------------------------------------------------------------------------- - */ + */ Tcl_Encoding Tcl_CreateEncoding(typePtr) @@ -981,16 +997,16 @@ Tcl_CreateEncoding(typePtr) hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &new); if (new == 0) { /* - * Remove old encoding from hash table, but don't delete it until - * last reference goes away. + * Remove old encoding from hash table, but don't delete it until last + * reference goes away. */ - + encodingPtr = (Encoding *) Tcl_GetHashValue(hPtr); encodingPtr->hPtr = NULL; } name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1); - + encodingPtr = (Encoding *) ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); encodingPtr->toUtfProc = typePtr->toUtfProc; @@ -1017,15 +1033,15 @@ Tcl_CreateEncoding(typePtr) * * Tcl_ExternalToUtfDString -- * - * Convert a source buffer from the specified encoding into UTF-8. - * If any of the bytes in the source buffer are invalid or cannot - * be represented in the target encoding, a default fallback - * character will be substituted. + * Convert a source buffer from the specified encoding into UTF-8. If any + * of the bytes in the source buffer are invalid or cannot be represented + * in the target encoding, a default fallback character will be + * substituted. * * Results: * The converted bytes are stored in the DString, which is then NULL - * terminated. The return value is a pointer to the value stored - * in the DString. + * terminated. The return value is a pointer to the value stored in the + * DString. * * Side effects: * None. @@ -1033,15 +1049,15 @@ Tcl_CreateEncoding(typePtr) *------------------------------------------------------------------------- */ -char * +char * Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) - Tcl_Encoding encoding; /* The encoding for the source string, or - * NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the source string, or NULL + * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ - Tcl_DString *dstPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { char *dst; Tcl_EncodingState state; @@ -1051,7 +1067,7 @@ Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; - + if (encoding == NULL) { encoding = systemEncoding; } @@ -1062,16 +1078,20 @@ Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) } else if (srcLen < 0) { srcLen = (*encodingPtr->lengthProc)(src); } + flags = TCL_ENCODING_START | TCL_ENCODING_END; + while (1) { result = (*encodingPtr->toUtfProc)(encodingPtr->clientData, src, srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } + flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; @@ -1093,11 +1113,11 @@ Tcl_ExternalToUtfDString(encoding, src, srcLen, dstPtr) * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, - * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, - * as documented in tcl.h. + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as + * documented in tcl.h. * * Side effects: - * The converted bytes are stored in the output buffer. + * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ @@ -1106,19 +1126,19 @@ int Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ - Tcl_Encoding encoding; /* The encoding for the source string, or - * NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the source string, or NULL + * for the default system encoding. */ CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -1136,7 +1156,7 @@ Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; - + if (encoding == NULL) { encoding = systemEncoding; } @@ -1163,8 +1183,8 @@ Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, /* * If there are any null characters in the middle of the buffer, they will - * converted to the UTF-8 null character (\xC080). To get the actual - * \0 at the end of the destination buffer, we need to append it manually. + * converted to the UTF-8 null character (\xC080). To get the actual \0 at + * the end of the destination buffer, we need to append it manually. */ dstLen--; @@ -1172,6 +1192,7 @@ Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr); dst[*dstWrotePtr] = '\0'; + return result; } @@ -1180,15 +1201,15 @@ Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, * * Tcl_UtfToExternalDString -- * - * Convert a source buffer from UTF-8 into the specified encoding. - * If any of the bytes in the source buffer are invalid or cannot - * be represented in the target encoding, a default fallback - * character will be substituted. + * Convert a source buffer from UTF-8 into the specified encoding. If + * any of the bytes in the source buffer are invalid or cannot be + * represented in the target encoding, a default fallback character will + * be substituted. * * Results: - * The converted bytes are stored in the DString, which is then - * NULL terminated in an encoding-specific manner. The return value - * is a pointer to the value stored in the DString. + * The converted bytes are stored in the DString, which is then NULL + * terminated in an encoding-specific manner. The return value is a + * pointer to the value stored in the DString. * * Side effects: * None. @@ -1198,19 +1219,19 @@ Tcl_ExternalToUtf(interp, encoding, src, srcLen, flags, statePtr, dst, char * Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) - Tcl_Encoding encoding; /* The encoding for the converted string, - * or NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the converted string, or + * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ - Tcl_DString *dstPtr; /* Uninitialized or free DString in which - * the converted string is stored. */ + Tcl_DString *dstPtr; /* Uninitialized or free DString in which the + * converted string is stored. */ { char *dst; Tcl_EncodingState state; Encoding *encodingPtr; int flags, dstLen, result, soFar, srcRead, dstWrote, dstChars; - + Tcl_DStringInit(dstPtr); dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; @@ -1231,13 +1252,15 @@ Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) srcLen, flags, &state, dst, dstLen, &srcRead, &dstWrote, &dstChars); soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); + if (result != TCL_CONVERT_NOSPACE) { if (encodingPtr->nullSize == 2) { - Tcl_DStringSetLength(dstPtr, soFar + 1); + Tcl_DStringSetLength(dstPtr, soFar + 1); } Tcl_DStringSetLength(dstPtr, soFar); return Tcl_DStringValue(dstPtr); } + flags &= ~TCL_ENCODING_START; src += srcRead; srcLen -= srcRead; @@ -1259,11 +1282,11 @@ Tcl_UtfToExternalDString(encoding, src, srcLen, dstPtr) * * Results: * The return value is one of TCL_OK, TCL_CONVERT_MULTIBYTE, - * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, - * as documented in tcl.h. + * TCL_CONVERT_SYNTAX, TCL_CONVERT_UNKNOWN, or TCL_CONVERT_NOSPACE, as + * documented in tcl.h. * * Side effects: - * The converted bytes are stored in the output buffer. + * The converted bytes are stored in the output buffer. * *------------------------------------------------------------------------- */ @@ -1272,14 +1295,14 @@ int Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) Tcl_Interp *interp; /* Interp for error return, if not NULL. */ - Tcl_Encoding encoding; /* The encoding for the converted string, - * or NULL for the default system encoding. */ + Tcl_Encoding encoding; /* The encoding for the converted string, or + * NULL for the default system encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes, or < 0 for * strlen(). */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ @@ -1302,7 +1325,7 @@ Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, Encoding *encodingPtr; int result, srcRead, dstWrote, dstChars; Tcl_EncodingState state; - + if (encoding == NULL) { encoding = systemEncoding; } @@ -1335,7 +1358,7 @@ Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, dst[*dstWrotePtr + 1] = '\0'; } dst[*dstWrotePtr] = '\0'; - + return result; } @@ -1351,8 +1374,8 @@ Tcl_UtfToExternal(interp, encoding, src, srcLen, flags, statePtr, dst, * None. * * Side effects: - * The absolute pathname for the application is computed and stored - * to be returned later be [info nameofexecutable]. + * The absolute pathname for the application is computed and stored to be + * returned later be [info nameofexecutable]. * *--------------------------------------------------------------------------- */ @@ -1375,14 +1398,14 @@ Tcl_FindExecutable(argv0) * Open the file believed to hold data for the encoding, "name". * * Results: - * Returns the readable Tcl_Channel from opening the file, or NULL - * if the file could not be successfully opened. If NULL was - * returned, an error message is left in interp's result object, - * unless interp was NULL. + * Returns the readable Tcl_Channel from opening the file, or NULL if the + * file could not be successfully opened. If NULL was * returned, an + * error message is left in interp's result object, * unless interp was + * NULL. * * Side effects: - * Channel may be opened. Information about the filesystem may be - * cached to speed later calls. + * Channel may be opened. Information about the filesystem may be cached + * to speed later calls. * *--------------------------------------------------------------------------- */ @@ -1390,8 +1413,8 @@ Tcl_FindExecutable(argv0) static Tcl_Channel OpenEncodingFileChannel(interp, name) Tcl_Interp *interp; /* Interp for error reporting, if not NULL. */ - CONST char *name; /* The name of the encoding file on disk - * and also the name for new encoding. */ + CONST char *name; /* The name of the encoding file on disk and + * also the name for new encoding. */ { Tcl_Obj *nameObj = Tcl_NewStringObj(name, -1); Tcl_Obj *fileNameObj = Tcl_DuplicateObj(nameObj); @@ -1407,7 +1430,10 @@ OpenEncodingFileChannel(interp, name) Tcl_IncrRefCount(fileNameObj); Tcl_DictObjGet(NULL, map, nameObj, &directory); - /* Check that any cached directory is still on the encoding search path */ + /* + * Check that any cached directory is still on the encoding search path. + */ + if (NULL != directory) { int verified = 0; @@ -1425,7 +1451,10 @@ OpenEncodingFileChannel(interp, name) } } if (!verified) { - /* Directory no longer on the search path. Remove from cache */ + /* + * Directory no longer on the search path. Remove from cache. + */ + map = Tcl_DuplicateObj(map); Tcl_DictObjRemove(NULL, map, nameObj); TclSetProcessGlobalValue(&encodingFileMap, map, NULL); @@ -1434,7 +1463,10 @@ OpenEncodingFileChannel(interp, name) } if (NULL != directory) { - /* Got a directory from the cache. Try to use it first */ + /* + * Got a directory from the cache. Try to use it first. + */ + Tcl_IncrRefCount(directory); path = Tcl_FSJoinToPath(directory, 1, &fileNameObj); Tcl_IncrRefCount(path); @@ -1443,25 +1475,33 @@ OpenEncodingFileChannel(interp, name) Tcl_DecrRefCount(path); } - /* Scan the search path until we find it. */ + /* + * Scan the search path until we find it. + */ + for (i=0; itoUnicode[hi] = pageMemPtr; p += 2; for (lo = 0; lo < 256; lo++) { if ((lo & 0x0f) == 0) { p++; } - ch = (staticHex[(unsigned int)p[0]] << 12) + (staticHex[(unsigned int)p[1]] << 8) - + (staticHex[(unsigned int)p[2]] << 4) + staticHex[(unsigned int)p[3]]; + ch = (staticHex[UCHAR(p[0])] << 12) + (staticHex[UCHAR(p[1])] << 8) + + (staticHex[UCHAR(p[2])] << 4) + staticHex[UCHAR(p[3])]; if (ch != 0) { used[ch >> 8] = 1; } @@ -1664,7 +1701,7 @@ LoadTableEncoding(name, type, chan) } } TclDecrRefCount(objPtr); - + if (type == ENCODING_DOUBLEBYTE) { memset(dataPtr->prefixBytes, 1, sizeof(dataPtr->prefixBytes)); } else { @@ -1677,9 +1714,9 @@ LoadTableEncoding(name, type, chan) /* * Invert toUnicode array to produce the fromUnicode array. Performs a - * single malloc to get the memory for the array and all the pages - * needed by the array. While reading in the toUnicode array, we - * remembered what pages that would be needed for the fromUnicode array. + * single malloc to get the memory for the array and all the pages needed + * by the array. While reading in the toUnicode array, we remembered what + * pages that would be needed for the fromUnicode array. */ if (symbol) { @@ -1706,7 +1743,7 @@ LoadTableEncoding(name, type, chan) ch = dataPtr->toUnicode[hi][lo]; if (ch != 0) { unsigned short *page; - + page = dataPtr->fromUnicode[ch >> 8]; if (page == NULL) { page = pageMemPtr; @@ -1734,16 +1771,15 @@ LoadTableEncoding(name, type, chan) } if (symbol) { unsigned short *page; - + /* * Make a special symbol encoding that not only maps the symbol * characters from their Unicode code points down into page 0, but - * also ensure that the characters on page 0 map to themselves. - * This is so that a symbol font can be used to display a simple - * string like "abcd" and have alpha, beta, chi, delta show up, - * rather than have "unknown" chars show up because strictly - * speaking the symbol font doesn't have glyphs for those low ascii - * chars. + * also ensure that the characters on page 0 map to themselves. This + * is so that a symbol font can be used to display a simple string + * like "abcd" and have alpha, beta, chi, delta show up, rather than + * have "unknown" chars show up because strictly speaking the symbol + * font doesn't have glyphs for those low ascii chars. */ page = dataPtr->fromUnicode[0]; @@ -1762,15 +1798,22 @@ LoadTableEncoding(name, type, chan) dataPtr->fromUnicode[hi] = emptyPage; } } + /* * For trailing 'R'everse encoding, see [Patch #689341] */ + Tcl_DStringInit(&lineString); do { int len; - /* skip leading empty lines */ + + /* + * Skip leading empty lines. + */ + while ((len = Tcl_Gets(chan, &lineString)) == 0) ; + if (len < 0) { break; } @@ -1779,16 +1822,17 @@ LoadTableEncoding(name, type, chan) break; } for (Tcl_DStringSetLength(&lineString, 0); - (len = Tcl_Gets(chan, &lineString)) >= 0; - Tcl_DStringSetLength(&lineString, 0)) { + (len = Tcl_Gets(chan, &lineString)) >= 0; + Tcl_DStringSetLength(&lineString, 0)) { unsigned char* p; int to, from; + if (len < 5) { continue; } p = (unsigned char*) Tcl_DStringValue(&lineString); to = (staticHex[p[0]] << 12) + (staticHex[p[1]] << 8) - + (staticHex[p[2]] << 4) + staticHex[p[3]]; + + (staticHex[p[2]] << 4) + staticHex[p[3]]; if (to == 0) { continue; } @@ -1810,6 +1854,7 @@ LoadTableEncoding(name, type, chan) encType.freeProc = TableFreeProc; encType.nullSize = (type == ENCODING_DOUBLEBYTE) ? 2 : 1; encType.clientData = (ClientData) dataPtr; + return Tcl_CreateEncoding(&encType); } @@ -1818,16 +1863,16 @@ LoadTableEncoding(name, type, chan) * * LoadEscapeEncoding -- * - * Helper function for LoadEncodingTable(). Loads a state machine - * that converts between Unicode and some other encoding. + * Helper function for LoadEncodingTable(). Loads a state machine that + * converts between Unicode and some other encoding. * - * File contains text data that describes the escape sequences that - * are used to choose an encoding and the associated names for the + * File contains text data that describes the escape sequences that are + * used to choose an encoding and the associated names for the * sub-encodings. * * Results: - * The return value is the new encoding, or NULL if the encoding - * could not be created (because the file contained invalid data). + * The return value is the new encoding, or NULL if the encoding could + * not be created (because the file contained invalid data). * * Side effects: * None. @@ -1856,13 +1901,13 @@ LoadEscapeEncoding(name, chan) CONST char **argv; char *line; Tcl_DString lineString; - + Tcl_DStringInit(&lineString); if (Tcl_Gets(chan, &lineString) < 0) { break; } line = Tcl_DStringValue(&lineString); - if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { + if (Tcl_SplitList(NULL, line, &argc, &argv) != TCL_OK) { continue; } if (argc >= 2) { @@ -1884,7 +1929,10 @@ LoadEscapeEncoding(name, chan) strncpy(est.name, argv[0], sizeof(est.name)); est.name[sizeof(est.name) - 1] = '\0'; - /* To avoid infinite recursion in [encoding system iso2022-*]*/ + /* + * To avoid infinite recursion in [encoding system iso2022-*] + */ + Tcl_GetEncoding(NULL, est.name); est.encodingPtr = NULL; @@ -1895,14 +1943,15 @@ LoadEscapeEncoding(name, chan) Tcl_DStringFree(&lineString); } - size = sizeof(EscapeEncodingData) - - sizeof(EscapeSubTable) + Tcl_DStringLength(&escapeData); + size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable) + + Tcl_DStringLength(&escapeData); dataPtr = (EscapeEncodingData *) ckalloc(size); dataPtr->initLen = strlen(init); strcpy(dataPtr->init, init); dataPtr->finalLen = strlen(final); strcpy(dataPtr->final, final); - dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); + dataPtr->numSubTables = + Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy((VOID *) dataPtr->subTables, (VOID *) Tcl_DStringValue(&escapeData), (size_t) Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); @@ -1933,9 +1982,9 @@ LoadEscapeEncoding(name, chan) * * BinaryProc -- * - * The default conversion when no other conversion is specified. - * No translation is done; source bytes are copied directly to - * destination bytes. + * The default conversion when no other conversion is specified. No + * translation is done; source bytes are copied directly to destination + * bytes. * * Results: * Returns TCL_OK if conversion was successful. @@ -1953,13 +2002,13 @@ BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *src; /* Source string (unknown encoding). */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -1992,14 +2041,13 @@ BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, return result; } - /* *------------------------------------------------------------------------- * * UtfExtToUtfIntProc -- * - * Convert from UTF-8 to UTF-8. While converting null-bytes from - * the Tcl's internal representation (0xc0, 0x80) to the official + * Convert from UTF-8 to UTF-8. While converting null-bytes from the + * Tcl's internal representation (0xc0, 0x80) to the official * representation (0x00). See UtfToUtfProc for details. * * Results: @@ -2010,15 +2058,16 @@ BinaryProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * *------------------------------------------------------------------------- */ -static int + +static int UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) + srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ @@ -2039,7 +2088,7 @@ UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 1); + srcReadPtr, dstWrotePtr, dstCharsPtr, 1); } /* @@ -2059,20 +2108,20 @@ UtfIntToUtfExtProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * *------------------------------------------------------------------------- */ -static int +static int UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr) + srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2088,7 +2137,7 @@ UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * output buffer. */ { return UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, 0); + srcReadPtr, dstWrotePtr, dstCharsPtr, 0); } /* @@ -2096,9 +2145,9 @@ UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * * UtfToUtfProc -- * - * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 - * translation is not a no-op, because it will turn a stream of - * improperly formed UTF-8 into a properly formed stream. + * Convert from UTF-8 to UTF-8. Note that the UTF-8 to UTF-8 translation + * is not a no-op, because it will turn a stream of improperly formed + * UTF-8 into a properly formed stream. * * Results: * Returns TCL_OK if conversion was successful. @@ -2109,37 +2158,36 @@ UtfExtToUtfIntProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, - srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode) + srcReadPtr, dstWrotePtr, dstCharsPtr, pureNullMode) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the - * source string that were converted. This - * may be less than the original source length - * if there was a problem converting some - * source characters. */ + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ int *dstCharsPtr; /* Filled with the number of characters that * correspond to the bytes stored in the * output buffer. */ - int pureNullMode; /* Convert embedded nulls from - * internal representation to real - * null-bytes or vice versa */ - + int pureNullMode; /* Convert embedded nulls from internal + * representation to real null-bytes or vice + * versa. */ { CONST char *srcStart, *srcEnd, *srcClose; char *dstStart, *dstEnd; @@ -2147,7 +2195,7 @@ UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, Tcl_UniChar ch; result = TCL_OK; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2172,19 +2220,19 @@ UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, result = TCL_CONVERT_NOSPACE; break; } - if (UCHAR(*src) < 0x80 && - !(UCHAR(*src) == 0 && pureNullMode == 0)) { + if (UCHAR(*src) < 0x80 && !(UCHAR(*src) == 0 && pureNullMode == 0)) { /* - * Copy 7bit chatacters, but skip null-bytes when we are - * in input mode, so that they get converted to 0xc080. + * Copy 7bit chatacters, but skip null-bytes when we are in input + * mode, so that they get converted to 0xc080. */ + *dst++ = *src++; - } else if (pureNullMode == 1 && - UCHAR(*src) == 0xc0 && - UCHAR(*(src+1)) == 0x80) { - /* + } else if (pureNullMode == 1 && UCHAR(*src) == 0xc0 && + UCHAR(*(src+1)) == 0x80) { + /* * Convert 0xc080 to real nulls when we are in output mode. */ + *dst++ = 0; src += 2; } else { @@ -2215,20 +2263,20 @@ UtfToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* Not used. */ CONST char *src; /* Source string in Unicode. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2246,7 +2294,7 @@ UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST Tcl_UniChar *wSrc, *wSrcStart, *wSrcEnd; char *dstEnd, *dstStart; int result, numChars; - + result = TCL_OK; if ((srcLen % sizeof(Tcl_UniChar)) != 0) { result = TCL_CONVERT_MULTIBYTE; @@ -2267,9 +2315,11 @@ UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, result = TCL_CONVERT_NOSPACE; break; } + /* * Special case for 1-byte utf chars for speed. */ + if (*wSrc && *wSrc < 0x80) { *dst++ = (char) *wSrc; } else { @@ -2300,20 +2350,21 @@ UnicodeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) - ClientData clientData; /* TableEncodingData that specifies encoding. */ + ClientData clientData; /* TableEncodingData that specifies + * encoding. */ CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2331,7 +2382,7 @@ UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *srcStart, *srcEnd, *srcClose; Tcl_UniChar *wDst, *wDstStart, *wDstEnd; int result, numChars; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2357,10 +2408,11 @@ UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, if (wDst > wDstEnd) { result = TCL_CONVERT_NOSPACE; break; - } + } src += TclUtfToUniChar(src, wDst); wDst++; } + *srcReadPtr = src - srcStart; *dstWrotePtr = (char *) wDst - (char *) wDstStart; *dstCharsPtr = numChars; @@ -2384,7 +2436,7 @@ UtfToUnicodeProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies @@ -2392,13 +2444,13 @@ TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2420,7 +2472,7 @@ TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, unsigned short **toUnicode; unsigned short *pageZero; TableEncodingData *dataPtr; - + srcStart = src; srcEnd = src + srcLen; @@ -2434,10 +2486,10 @@ TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, result = TCL_OK; for (numChars = 0; src < srcEnd; numChars++) { - if (dst > dstEnd) { - result = TCL_CONVERT_NOSPACE; - break; - } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } byte = *((unsigned char *) src); if (prefixBytes[byte]) { src++; @@ -2468,8 +2520,9 @@ TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } else { dst += Tcl_UniCharToUtf(ch, dst); } - src++; + src++; } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; @@ -2493,7 +2546,7 @@ TableToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* TableEncodingData that specifies @@ -2501,13 +2554,13 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2528,13 +2581,13 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, int result, len, word, numChars; TableEncodingData *dataPtr; unsigned short **fromUnicode; - - result = TCL_OK; + + result = TCL_OK; dataPtr = (TableEncodingData *) clientData; prefixBytes = dataPtr->prefixBytes; fromUnicode = dataPtr->fromUnicode; - + srcStart = src; srcEnd = src + srcLen; srcClose = srcEnd; @@ -2559,9 +2612,10 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, #if TCL_UTF_MAX > 3 /* - * This prevents a crash condition. More evaluation is required - * for full support of int Tcl_UniChar. [Bug 1004065] + * This prevents a crash condition. More evaluation is required for + * full support of int Tcl_UniChar. [Bug 1004065] */ + if (ch & 0xffff0000) { word = 0; } else @@ -2573,7 +2627,7 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, result = TCL_CONVERT_UNKNOWN; break; } - word = dataPtr->fallback; + word = dataPtr->fallback; } if (prefixBytes[(word >> 8)] != 0) { if (dst + 1 > dstEnd) { @@ -2590,9 +2644,10 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } dst[0] = (char) word; dst++; - } + } src += len; } + *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; *dstCharsPtr = numChars; @@ -2604,8 +2659,8 @@ TableFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * * TableFreeProc -- * - * This procedure is invoked when an encoding is deleted. It deletes - * the memory used by the TableEncodingData. + * This procedure is invoked when an encoding is deleted. It deletes the + * memory used by the TableEncodingData. * * Results: * None. @@ -2650,7 +2705,7 @@ TableFreeProc(clientData) *------------------------------------------------------------------------- */ -static int +static int EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies @@ -2658,13 +2713,13 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *src; /* Source string in specified encoding. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the @@ -2710,54 +2765,56 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, for (numChars = 0; src < srcEnd; ) { int byte, hi, lo, ch; - if (dst > dstEnd) { - result = TCL_CONVERT_NOSPACE; - break; - } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } byte = *((unsigned char *) src); if (prefixBytes[byte]) { unsigned int left, len, longest; int checked, i; EscapeSubTable *subTablePtr; - + /* - * Saw the beginning of an escape sequence. + * Saw the beginning of an escape sequence. */ - + left = srcEnd - src; len = dataPtr->initLen; longest = len; checked = 0; + if (len <= left) { checked++; - if ((len > 0) && - (memcmp(src, dataPtr->init, len) == 0)) { + if ((len > 0) && (memcmp(src, dataPtr->init, len) == 0)) { /* * If we see initialization string, skip it, even if we're - * not at the beginning of the buffer. + * not at the beginning of the buffer. */ - + src += len; continue; } } + len = dataPtr->finalLen; if (len > longest) { longest = len; } + if (len <= left) { checked++; - if ((len > 0) && - (memcmp(src, dataPtr->final, len) == 0)) { + if ((len > 0) && (memcmp(src, dataPtr->final, len) == 0)) { /* * If we see finalization string, skip it, even if we're - * not at the end of the buffer. + * not at the end of the buffer. */ - + src += len; continue; } } + subTablePtr = dataPtr->subTables; for (i = 0; i < dataPtr->numSubTables; i++) { len = subTablePtr->sequenceLen; @@ -2766,7 +2823,7 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } if (len <= left) { checked++; - if ((len > 0) && + if ((len > 0) && (memcmp(src, subTablePtr->sequence, len) == 0)) { state = i; encodingPtr = NULL; @@ -2777,6 +2834,7 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } subTablePtr++; } + if (subTablePtr == NULL) { /* * A match was found, the escape sequence was consumed, and @@ -2788,8 +2846,8 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, /* * We have a split-up or unrecognized escape sequence. If we - * checked all the sequences, then it's a syntax error, - * otherwise we need more bytes to determine a match. + * checked all the sequences, then it's a syntax error, otherwise + * we need more bytes to determine a match. */ if ((checked == dataPtr->numSubTables + 2) @@ -2817,6 +2875,7 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, tablePrefixBytes = tableDataPtr->prefixBytes; tableToUnicode = tableDataPtr->toUnicode; } + if (tablePrefixBytes[byte]) { src++; if (src >= srcEnd) { @@ -2830,6 +2889,7 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, hi = 0; lo = byte; } + ch = tableToUnicode[hi][lo]; dst += Tcl_UniCharToUtf(ch, dst); src++; @@ -2860,7 +2920,7 @@ EscapeToUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *------------------------------------------------------------------------- */ -static int +static int EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, srcReadPtr, dstWrotePtr, dstCharsPtr) ClientData clientData; /* EscapeEncodingData that specifies @@ -2868,20 +2928,20 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, CONST char *src; /* Source string in UTF-8. */ int srcLen; /* Source string length in bytes. */ int flags; /* Conversion control flags. */ - Tcl_EncodingState *statePtr;/* Place for conversion routine to store - * state information used during a piecewise + Tcl_EncodingState *statePtr;/* Place for conversion routine to store state + * information used during a piecewise * conversion. Contents of statePtr are * initialized and/or reset by conversion * routine under control of flags argument. */ - char *dst; /* Output buffer in which converted string - * is stored. */ + char *dst; /* Output buffer in which converted string is + * stored. */ int dstLen; /* The maximum length of output buffer in * bytes. */ int *srcReadPtr; /* Filled with the number of bytes from the - * source string that were converted. This - * may be less than the original source length - * if there was a problem converting some - * source characters. */ + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ int *dstWrotePtr; /* Filled with the number of bytes that were * stored in the output buffer as a result of * the conversion. */ @@ -2897,8 +2957,8 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, TableEncodingData *tableDataPtr; char *tablePrefixBytes; unsigned short **tableFromUnicode; - - result = TCL_OK; + + result = TCL_OK; dataPtr = (EscapeEncodingData *) clientData; @@ -2924,11 +2984,10 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } - memcpy((VOID *) dst, (VOID *) dataPtr->init, - (size_t) dataPtr->initLen); + memcpy((VOID *)dst, (VOID *)dataPtr->init, (size_t)dataPtr->initLen); dst += dataPtr->initLen; } else { - state = (int) *statePtr; + state = (int) *statePtr; } encodingPtr = GetTableEncoding(dataPtr, state); @@ -2940,7 +2999,7 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, unsigned int len; int word; Tcl_UniChar ch; - + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { /* * If there is more string to follow, this will ensure that the @@ -2956,7 +3015,7 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, if ((word == 0) && (ch != 0)) { int oldState; EscapeSubTable *subTablePtr; - + oldState = state; for (state = 0; state < dataPtr->numSubTables; state++) { encodingPtr = GetTableEncoding(dataPtr, state); @@ -2976,16 +3035,17 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, encodingPtr = GetTableEncoding(dataPtr, state); tableDataPtr = (TableEncodingData *) encodingPtr->clientData; word = tableDataPtr->fallback; - } - + } + tablePrefixBytes = tableDataPtr->prefixBytes; tableFromUnicode = tableDataPtr->fromUnicode; /* * The state variable has the value of oldState when word is 0. - * In this case, the escape sequense should not be copied to dst + * In this case, the escape sequense should not be copied to dst * because the current character set is not changed. */ + if (state != oldState) { subTablePtr = &dataPtr->subTables[state]; if ((dst + subTablePtr->sequenceLen) > dstEnd) { @@ -2995,6 +3055,7 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * variable because this escape sequence must be written * in the next conversion. */ + state = oldState; result = TCL_CONVERT_NOSPACE; break; @@ -3020,7 +3081,7 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, } dst[0] = (char) word; dst++; - } + } src += len; } @@ -3052,7 +3113,7 @@ EscapeFromUtfProc(clientData, src, srcLen, flags, statePtr, dst, dstLen, * * EscapeFreeProc -- * - * This procedure is invoked when an EscapeEncodingData encoding is + * This procedure is invoked when an EscapeEncodingData encoding is * deleted. It deletes the memory used by the encoding. * * Results: @@ -3097,9 +3158,9 @@ EscapeFreeProc(clientData) * The return value is the encoding. * * Side effects: - * If the encoding that represents the specified state has not - * already been used by this EscapeEncoding, it will be loaded - * and cached in the dataPtr. + * If the encoding that represents the specified state has not already + * been used by this EscapeEncoding, it will be loaded and cached in the + * dataPtr. * *--------------------------------------------------------------------------- */ @@ -3111,17 +3172,19 @@ GetTableEncoding(dataPtr, state) { EscapeSubTable *subTablePtr; Encoding *encodingPtr; - + subTablePtr = &dataPtr->subTables[state]; encodingPtr = subTablePtr->encodingPtr; + if (encodingPtr == NULL) { encodingPtr = (Encoding *) Tcl_GetEncoding(NULL, subTablePtr->name); - if ((encodingPtr == NULL) + if ((encodingPtr == NULL) || (encodingPtr->toUtfProc != TableToUtfProc)) { Tcl_Panic("EscapeToUtfProc: invalid sub table"); } subTablePtr->encodingPtr = encodingPtr; } + return encodingPtr; } @@ -3130,9 +3193,9 @@ GetTableEncoding(dataPtr, state) * * unilen -- * - * A helper function for the Tcl_ExternalToUtf functions. This - * function is similar to strlen for double-byte characters: it - * returns the number of bytes in a 0x0000 terminated string. + * A helper function for the Tcl_ExternalToUtf functions. This function + * is similar to strlen for double-byte characters: it returns the number + * of bytes in a 0x0000 terminated string. * * Results: * As above. @@ -3161,28 +3224,27 @@ unilen(src) * * InitializeEncodingSearchPath -- * - * This is the fallback routine that sets the default value - * of the encoding search path if the application has not set - * one via a call to TclSetEncodingSearchPath() by the first - * time the search path is needed to load encoding data. + * This is the fallback routine that sets the default value of the + * encoding search path if the application has not set one via a call to + * TclSetEncodingSearchPath() by the first time the search path is needed + * to load encoding data. * - * The default encoding search path is produced by taking each - * directory in the library path, appending a subdirectory - * named "encoding", and if the resulting directory exists, - * adding it to the encoding search path. + * The default encoding search path is produced by taking each directory + * in the library path, appending a subdirectory named "encoding", and if + * the resulting directory exists, adding it to the encoding search path. * * Results: * None. * * Side effects: - * Sets the encoding search path to an initial value. + * Sets the encoding search path to an initial value. * *------------------------------------------------------------------------- */ void InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) - char **valuePtr; + char **valuePtr; int *lengthPtr; Tcl_Encoding *encodingPtr; { @@ -3196,18 +3258,20 @@ InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) libPath = TclGetLibraryPath(); Tcl_IncrRefCount(libPath); Tcl_ListObjLength(NULL, libPath, &numDirs); + for (i = 0; i < numDirs; i++) { Tcl_Obj *directory, *path; Tcl_StatBuf stat; Tcl_ListObjIndex(NULL, libPath, i, &directory); - path = Tcl_FSJoinToPath(directory, 1, &encodingObj); + path = Tcl_FSJoinToPath(directory, 1, &encodingObj); Tcl_IncrRefCount(path); if ((0 == Tcl_FSStat(path, &stat)) && S_ISDIR(stat.st_mode)) { Tcl_ListObjAppendElement(NULL, searchPath, path); } Tcl_DecrRefCount(path); } + Tcl_DecrRefCount(libPath); Tcl_DecrRefCount(encodingObj); *encodingPtr = libraryPath.encoding; @@ -3215,8 +3279,17 @@ InitializeEncodingSearchPath(valuePtr, lengthPtr, encodingPtr) ((Encoding *)(*encodingPtr))->refCount++; } bytes = Tcl_GetStringFromObj(searchPath, &numBytes); + *lengthPtr = numBytes; *valuePtr = ckalloc((unsigned int) numBytes + 1); memcpy((VOID *) *valuePtr, (VOID *) bytes, (size_t) numBytes + 1); Tcl_DecrRefCount(searchPath); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclEvent.c b/generic/tclEvent.c index fb58f0f..e70ce67 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -2,42 +2,41 @@ * tclEvent.c -- * * This file implements some general event related interfaces including - * background errors, exit handlers, and the "vwait" and "update" - * command procedures. + * background errors, exit handlers, and the "vwait" and "update" command + * procedures. * * Copyright (c) 1990-1994 The Regents of the University of California. * Copyright (c) 1994-1998 Sun Microsystems, Inc. * Copyright (c) 2004 by Zoran Vasiljevic. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclEvent.c,v 1.59 2005/06/24 20:07:21 kennykb Exp $ + * RCS: @(#) $Id: tclEvent.c,v 1.60 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" /* - * The data structure below is used to report background errors. One - * such structure is allocated for each error; it holds information - * about the interpreter and the error until an idle handler command - * can be invoked. + * The data structure below is used to report background errors. One such + * structure is allocated for each error; it holds information about the + * interpreter and the error until an idle handler command can be invoked. */ typedef struct BgError { Tcl_Obj *errorMsg; /* Copy of the error message (the interp's * result when the error occurred). */ - Tcl_Obj *returnOpts; /* Active return options when the - * error occurred */ - struct BgError *nextPtr; /* Next in list of all pending error - * reports for this interpreter, or NULL - * for end of list. */ + Tcl_Obj *returnOpts; /* Active return options when the error + * occurred */ + struct BgError *nextPtr; /* Next in list of all pending error reports + * for this interpreter, or NULL for end of + * list. */ } BgError; /* - * One of the structures below is associated with the "tclBgError" - * assoc data for each interpreter. It keeps track of the head and - * tail of the list of pending background errors for the interpreter. + * One of the structures below is associated with the "tclBgError" assoc data + * for each interpreter. It keeps track of the head and tail of the list of + * pending background errors for the interpreter. */ typedef struct ErrAssocData { @@ -59,14 +58,13 @@ typedef struct ErrAssocData { typedef struct ExitHandler { Tcl_ExitProc *proc; /* Procedure to call when process exits. */ ClientData clientData; /* One word of information to pass to proc. */ - struct ExitHandler *nextPtr;/* Next in list of all exit handlers for - * this application, or NULL for end of list. */ + struct ExitHandler *nextPtr;/* Next in list of all exit handlers for this + * application, or NULL for end of list. */ } ExitHandler; /* - * There is both per-process and per-thread exit handlers. - * The first list is controlled by a mutex. The other is in - * thread local storage. + * There is both per-process and per-thread exit handlers. The first list is + * controlled by a mutex. The other is in thread local storage. */ static ExitHandler *firstExitPtr = NULL; @@ -76,9 +74,9 @@ TCL_DECLARE_MUTEX(exitMutex) /* * This variable is set to 1 when Tcl_Finalize is called, and at the end of - * its work, it is reset to 0. The variable is checked by TclInExit() to - * allow different behavior for exit-time processing, e.g. in closing of - * files and pipes. + * its work, it is reset to 0. The variable is checked by TclInExit() to allow + * different behavior for exit-time processing, e.g. in closing of files and + * pipes. */ static int inFinalize = 0; @@ -93,11 +91,11 @@ static int subsystemsInitialized = 0; static Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { - ExitHandler *firstExitPtr; /* First in list of all exit handlers for - * this thread. */ - int inExit; /* True when this thread is exiting. This - * is used as a hack to decide to close - * the standard channels. */ + ExitHandler *firstExitPtr; /* First in list of all exit handlers for this + * thread. */ + int inExit; /* True when this thread is exiting. This is + * used as a hack to decide to close the + * standard channels. */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -108,7 +106,7 @@ typedef struct { ClientData clientData; /* The one argument to Main() */ } ThreadClientData; static Tcl_ThreadCreateType NewThreadProc _ANSI_ARGS_(( - ClientData clientData)); + ClientData clientData)); #endif /* @@ -127,17 +125,15 @@ static char * VwaitVarProc _ANSI_ARGS_((ClientData clientData, * * Tcl_BackgroundError -- * - * This procedure is invoked to handle errors that occur in Tcl - * commands that are invoked in "background" (e.g. from event or - * timer bindings). + * This procedure is invoked to handle errors that occur in Tcl commands + * that are invoked in "background" (e.g. from event or timer bindings). * * Results: * None. * * Side effects: - * A handler command is invoked later as an idle handler to - * process the error, passing it the interp result and return - * options. + * A handler command is invoked later as an idle handler to process the + * error, passing it the interp result and return options. * *---------------------------------------------------------------------- */ @@ -175,8 +171,8 @@ Tcl_BackgroundError(interp) * * HandleBgErrors -- * - * This procedure is invoked as an idle handler to process all of - * the accumulated background errors. + * This procedure is invoked as an idle handler to process all of the + * accumulated background errors. * * Results: * None. @@ -196,10 +192,10 @@ HandleBgErrors(clientData) BgError *errPtr; /* - * Not bothering to save/restore the interp state. Assume that - * any code that has interp state it needs to keep will make - * its own Tcl_SaveInterpState call before calling something like - * Tcl_DoOneEvent() that could lead us here. + * Not bothering to save/restore the interp state. Assume that any code + * that has interp state it needs to keep will make its own + * Tcl_SaveInterpState call before calling something like Tcl_DoOneEvent() + * that could lead us here. */ Tcl_Preserve((ClientData) assocPtr); @@ -211,8 +207,8 @@ HandleBgErrors(clientData) errPtr = assocPtr->firstBgPtr; Tcl_IncrRefCount(assocPtr->cmdPrefix); - Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, - &prefixObjc, &prefixObjv); + Tcl_ListObjGetElements(NULL, assocPtr->cmdPrefix, &prefixObjc, + &prefixObjv); tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2)*sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; @@ -261,7 +257,7 @@ HandleBgErrors(clientData) Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); } Tcl_WriteChars(errChannel, "\n", 1); - Tcl_Flush(errChannel); + Tcl_Flush(errChannel); } } } @@ -275,10 +271,9 @@ HandleBgErrors(clientData) * * TclDefaultBgErrorHandlerObjCmd -- * - * This procedure is invoked to process the "::tcl::Bgerror" Tcl - * command. It is the default handler command registered with - * [interp bgerror] for the sake of compatibility with older Tcl - * releases. + * This procedure is invoked to process the "::tcl::Bgerror" Tcl command. + * It is the default handler command registered with [interp bgerror] for + * the sake of compatibility with older Tcl releases. * * Results: * A standard Tcl object result. @@ -291,10 +286,10 @@ HandleBgErrors(clientData) int TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ + ClientData dummy; /* Not used. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Obj *keyPtr, *valuePtr; Tcl_Obj *tempObjv[2]; @@ -306,12 +301,12 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) } /* - * Restore important state variables to what they were at - * the time the error occurred. + * Restore important state variables to what they were at the time the + * error occurred. * - * Need to set the variables, not the interp fields, because - * Tcl_EvalObjv() calls Tcl_ResetResult() which would destroy - * anything we write to the interp fields. + * Need to set the variables, not the interp fields, because Tcl_EvalObjv + * calls Tcl_ResetResult which would destroy anything we write to the + * interp fields. */ keyPtr = Tcl_NewStringObj("-errorcode", -1); @@ -330,7 +325,9 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) Tcl_SetVar2Ex(interp, "errorInfo", NULL, valuePtr, TCL_GLOBAL_ONLY); } - /* Create and invoke the bgerror command. */ + /* + * Create and invoke the bgerror command. + */ tempObjv[0] = Tcl_NewStringObj("bgerror", -1); Tcl_IncrRefCount(tempObjv[0]); @@ -338,16 +335,16 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) Tcl_AllowExceptions(interp); code = Tcl_EvalObjv(interp, 2, tempObjv, TCL_EVAL_GLOBAL); if (code == TCL_ERROR) { - /* - * If the interpreter is safe, we look for a hidden command - * named "bgerror" and call that with the error information. - * Otherwise, simply ignore the error. The rationale is that - * this could be an error caused by a malicious applet trying - * to cause an infinite barrage of error messages. The hidden - * "bgerror" command can be used by a security policy to - * interpose on such attacks and e.g. kill the applet after a - * few attempts. - */ + /* + * If the interpreter is safe, we look for a hidden command named + * "bgerror" and call that with the error information. Otherwise, + * simply ignore the error. The rationale is that this could be an + * error caused by a malicious applet trying to cause an infinite + * barrage of error messages. The hidden "bgerror" command can be used + * by a security policy to interpose on such attacks and e.g. kill the + * applet after a few attempts. + */ + if (Tcl_IsSafe(interp)) { Tcl_ResetResult(interp); TclObjInvoke(interp, 2, tempObjv, TCL_INVOKE_HIDDEN); @@ -357,25 +354,24 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - if (Tcl_FindCommand(interp, "bgerror", - NULL, TCL_GLOBAL_ONLY) == NULL) { + if (Tcl_FindCommand(interp, "bgerror", NULL, + TCL_GLOBAL_ONLY) == NULL) { if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); Tcl_WriteChars(errChannel, "\n", -1); } - } else { + } else { Tcl_WriteChars(errChannel, "bgerror failed to handle background error.\n", -1); Tcl_WriteChars(errChannel, " Original error: ", -1); Tcl_WriteObj(errChannel, objv[1]); Tcl_WriteChars(errChannel, "\n", -1); - Tcl_WriteChars(errChannel, - " Error in bgerror: ", -1); + Tcl_WriteChars(errChannel, " Error in bgerror: ", -1); Tcl_WriteObj(errChannel, resultPtr); Tcl_WriteChars(errChannel, "\n", -1); - } + } Tcl_DecrRefCount(resultPtr); - Tcl_Flush(errChannel); + Tcl_Flush(errChannel); } } code = TCL_OK; @@ -390,8 +386,8 @@ TclDefaultBgErrorHandlerObjCmd(dummy, interp, objc, objv) * * TclSetBgErrorHandler -- * - * This procedure sets the command prefix to be used to handle - * background errors in interp. + * This procedure sets the command prefix to be used to handle background + * errors in interp. * * Results: * None. @@ -435,8 +431,8 @@ TclSetBgErrorHandler(interp, cmdPrefix) * * TclGetBgErrorHandler -- * - * This procedure retrieves the command prefix currently used - * to handle background errors in interp. + * This procedure retrieves the command prefix currently used to handle + * background errors in interp. * * Results: * A (Tcl_Obj *) to a list of words (command prefix). @@ -467,17 +463,16 @@ TclGetBgErrorHandler(interp) * * BgErrorDeleteProc -- * - * This procedure is associated with the "tclBgError" assoc data - * for an interpreter; it is invoked when the interpreter is - * deleted in order to free the information assoicated with any - * pending error reports. + * This procedure is associated with the "tclBgError" assoc data for an + * interpreter; it is invoked when the interpreter is deleted in order to + * free the information assoicated with any pending error reports. * * Results: * None. * * Side effects: - * Background error information is freed: if there were any - * pending error reports, they are cancelled. + * Background error information is freed: if there were any pending error + * reports, they are cancelled. * *---------------------------------------------------------------------- */ @@ -514,8 +509,8 @@ BgErrorDeleteProc(clientData, interp) * None. * * Side effects: - * Proc will be invoked with clientData as argument when the - * application exits. + * Proc will be invoked with clientData as argument when the application + * exits. * *---------------------------------------------------------------------- */ @@ -541,16 +536,15 @@ Tcl_CreateExitHandler(proc, clientData) * * Tcl_DeleteExitHandler -- * - * This procedure cancels an existing exit handler matching proc - * and clientData, if such a handler exits. + * This procedure cancels an existing exit handler matching proc and + * clientData, if such a handler exits. * * Results: * None. * * Side effects: - * If there is an exit handler corresponding to proc and clientData - * then it is cancelled; if no such handler exists then nothing - * happens. + * If there is an exit handler corresponding to proc and clientData then + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ @@ -585,15 +579,15 @@ Tcl_DeleteExitHandler(proc, clientData) * * Tcl_CreateThreadExitHandler -- * - * Arrange for a given procedure to be invoked just before the - * current thread exits. + * Arrange for a given procedure to be invoked just before the current + * thread exits. * * Results: * None. * * Side effects: - * Proc will be invoked with clientData as argument when the - * application exits. + * Proc will be invoked with clientData as argument when the application + * exits. * *---------------------------------------------------------------------- */ @@ -618,16 +612,15 @@ Tcl_CreateThreadExitHandler(proc, clientData) * * Tcl_DeleteThreadExitHandler -- * - * This procedure cancels an existing exit handler matching proc - * and clientData, if such a handler exits. + * This procedure cancels an existing exit handler matching proc and + * clientData, if such a handler exits. * * Results: * None. * * Side effects: - * If there is an exit handler corresponding to proc and clientData - * then it is cancelled; if no such handler exists then nothing - * happens. + * If there is an exit handler corresponding to proc and clientData then + * it is cancelled; if no such handler exists then nothing happens. * *---------------------------------------------------------------------- */ @@ -660,10 +653,9 @@ Tcl_DeleteThreadExitHandler(proc, clientData) * * Tcl_SetExitProc -- * - * This procedure sets the application wide exit handler that - * will be called by Tcl_Exit in place of the C-runtime exit. If - * the application wide exit handler is NULL, the C-runtime exit - * will be used instead. + * This procedure sets the application wide exit handler that will be + * called by Tcl_Exit in place of the C-runtime exit. If the application + * wide exit handler is NULL, the C-runtime exit will be used instead. * * Results: * The previously set application wide exit handler. @@ -681,8 +673,8 @@ Tcl_SetExitProc(proc) Tcl_ExitProc *prevExitProc; /* - * Swap the old exit proc for the new one, saving the old one for - * our return value. + * Swap the old exit proc for the new one, saving the old one for our + * return value. */ Tcl_MutexLock(&exitMutex); @@ -704,8 +696,7 @@ Tcl_SetExitProc(proc) * None. * * Side effects: - * All existing exit handlers are invoked, then the application - * ends. + * All existing exit handlers are invoked, then the application ends. * *---------------------------------------------------------------------- */ @@ -723,10 +714,11 @@ Tcl_Exit(status) if (currentAppExitPtr) { /* - * Warning: this code SHOULD NOT return, as there is code that - * depends on Tcl_Exit never returning. In fact, we will - * Tcl_Panic if anyone returns, so critical is this dependcy. + * Warning: this code SHOULD NOT return, as there is code that depends + * on Tcl_Exit never returning. In fact, we will Tcl_Panic if anyone + * returns, so critical is this dependcy. */ + currentAppExitPtr((ClientData) status); Tcl_Panic("AppExitProc returned unexpectedly"); } else { @@ -742,17 +734,16 @@ Tcl_Exit(status) * * TclInitSubsystems -- * - * Initialize various subsytems in Tcl. This should be called the - * first time an interp is created, or before any of the subsystems - * are used. This function ensures an order for the initialization - * of subsystems: + * Initialize various subsytems in Tcl. This should be called the first + * time an interp is created, or before any of the subsystems are used. + * This function ensures an order for the initialization of subsystems: * - * 1. that cannot be initialized in lazy order because they are - * mutually dependent. + * 1. that cannot be initialized in lazy order because they are mutually + * dependent. * - * 2. so that they can be finalized in a known order w/o causing - * the subsequent re-initialization of a subsystem in the act of - * shutting down another. + * 2. so that they can be finalized in a known order w/o causing the + * subsequent re-initialization of a subsystem in the act of shutting + * down another. * * Results: * None. @@ -772,15 +763,15 @@ TclInitSubsystems() if (subsystemsInitialized == 0) { /* - * Double check inside the mutex. There are definitly calls - * back into this routine from some of the procedures below. + * Double check inside the mutex. There are definitly calls back into + * this routine from some of the procedures below. */ TclpInitLock(); if (subsystemsInitialized == 0) { /* - * Have to set this bit here to avoid deadlock with the - * routines below us that call into TclInitSubsystems. + * Have to set this bit here to avoid deadlock with the routines + * below us that call into TclInitSubsystems. */ subsystemsInitialized = 1; @@ -790,21 +781,23 @@ TclInitSubsystems() * interesting happens so we can use the allocators in the * implementation of self-initializing locks. */ + #if USE_TCLALLOC - TclInitAlloc(); /* process wide mutex init */ + TclInitAlloc(); /* Process wide mutex init */ #endif #ifdef TCL_MEM_DEBUG - TclInitDbCkalloc(); /* process wide mutex init */ + TclInitDbCkalloc(); /* Process wide mutex init */ #endif - TclpInitPlatform(); /* creates signal handler(s) */ - TclInitDoubleConversion(); /* initializes constants for - * converting to/from double */ - TclInitObjSubsystem(); /* register obj types, create mutexes */ - TclInitIOSubsystem(); /* inits a tsd key (noop) */ - TclInitEncodingSubsystem(); /* process wide encoding init */ + TclpInitPlatform(); /* Creates signal handler(s) */ + TclInitDoubleConversion(); /* Initializes constants for + * converting to/from double. */ + TclInitObjSubsystem(); /* Register obj types, create + * mutexes. */ + TclInitIOSubsystem(); /* Inits a tsd key (noop). */ + TclInitEncodingSubsystem(); /* Process wide encoding init. */ TclpSetInterfaces(); - TclInitNamespaceSubsystem(); /* register ns obj type (mutexed) */ + TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ } TclpInitUnlock(); } @@ -816,10 +809,9 @@ TclInitSubsystems() * * Tcl_Finalize -- * - * Shut down Tcl. First calls registered exit handlers, then - * carefully shuts down various subsystems. - * Called by Tcl_Exit or when the Tcl shared library is being - * unloaded. + * Shut down Tcl. First calls registered exit handlers, then carefully + * shuts down various subsystems. Called by Tcl_Exit or when the Tcl + * shared library is being unloaded. * * Results: * None. @@ -843,10 +835,9 @@ Tcl_Finalize() inFinalize = 1; for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) { /* - * Be careful to remove the handler from the list before - * invoking its callback. This protects us against - * double-freeing if the callback should call - * Tcl_DeleteExitHandler on itself. + * Be careful to remove the handler from the list before invoking its + * callback. This protects us against double-freeing if the callback + * should call Tcl_DeleteExitHandler on itself. */ firstExitPtr = exitPtr->nextPtr; @@ -863,105 +854,108 @@ Tcl_Finalize() subsystemsInitialized = 0; /* - * Ensure the thread-specific data is initialised as it is - * used in Tcl_FinalizeThread() + * Ensure the thread-specific data is initialised as it is used in + * Tcl_FinalizeThread() */ (void) TCL_TSD_INIT(&dataKey); /* - * Clean up after the current thread now, after exit handlers. - * In particular, the testexithandler command sets up something - * that writes to standard output, which gets closed. - * Note that there is no thread-local storage after this call. + * Clean up after the current thread now, after exit handlers. In + * particular, the testexithandler command sets up something that + * writes to standard output, which gets closed. Note that there is + * no thread-local storage after this call. */ Tcl_FinalizeThread(); /* - * Now finalize the Tcl execution environment. Note that this - * must be done after the exit handlers, because there are - * order dependencies. + * Now finalize the Tcl execution environment. Note that this must be + * done after the exit handlers, because there are order dependencies. */ TclFinalizeCompExecEnv(); TclFinalizeEnvironment(); /* - * Finalizing the filesystem must come after anything which - * might conceivably interact with the 'Tcl_FS' API. + * Finalizing the filesystem must come after anything which might + * conceivably interact with the 'Tcl_FS' API. */ + TclFinalizeFilesystem(); /* - * We must be sure the encoding finalization doesn't need - * to examine the filesystem in any way. Since it only - * needs to clean up internal data structures, this is - * fine. + * We must be sure the encoding finalization doesn't need to examine + * the filesystem in any way. Since it only needs to clean up + * internal data structures, this is fine. */ + TclFinalizeEncodingSubsystem(); Tcl_SetPanicProc(NULL); /* - * Repeat finalization of the thread local storage once more. - * Although this step is already done by the Tcl_FinalizeThread - * call above, series of events happening afterwards may - * re-initialize TSD slots. Those need to be finalized again, - * otherwise we're leaking memory chunks. - * Very important to note is that things happening afterwards - * should not reference anything which may re-initialize TSD's. - * This includes freeing Tcl_Objs's, among other things. + * Repeat finalization of the thread local storage once more. Although + * this step is already done by the Tcl_FinalizeThread call above, + * series of events happening afterwards may re-initialize TSD slots. + * Those need to be finalized again, otherwise we're leaking memory + * chunks. Very important to note is that things happening afterwards + * should not reference anything which may re-initialize TSD's. This + * includes freeing Tcl_Objs's, among other things. * * This fixes the Tcl Bug #990552. */ + TclFinalizeThreadData(); /* * Free synchronization objects. There really should only be one * thread alive at this moment. */ + TclFinalizeSynchronization(); /* - * We defer unloading of packages until very late - * to avoid memory access issues. Both exit callbacks and - * synchronization variables may be stored in packages. + * We defer unloading of packages until very late to avoid memory + * access issues. Both exit callbacks and synchronization variables + * may be stored in packages. * - * Note that TclFinalizeLoad unloads packages in the reverse - * of the order they were loaded in (i.e. last to be loaded - * is the first to be unloaded). This can be important for - * correct unloading when dependencies exist. + * Note that TclFinalizeLoad unloads packages in the reverse of the + * order they were loaded in (i.e. last to be loaded is the first to + * be unloaded). This can be important for correct unloading when + * dependencies exist. * - * Once load has been finalized, we will have deleted any - * temporary copies of shared libraries and can therefore - * reset the filesystem to its original state. + * Once load has been finalized, we will have deleted any temporary + * copies of shared libraries and can therefore reset the filesystem + * to its original state. */ TclFinalizeLoad(); TclResetFilesystem(); - /* Now we can free constants for conversions to/from double */ + /* + * Now we can free constants for conversions to/from double. + */ TclFinalizeDoubleConversion(); /* - * There have been several bugs in the past that cause - * exit handlers to be established during Tcl_Finalize - * processing. Such exit handlers leave malloc'ed memory, - * and Tcl_FinalizeThreadAlloc or Tcl_FinalizeMemorySubsystem - * will result in a corrupted heap. The result can be a - * mysterious crash on process exit. Check here that + * There have been several bugs in the past that cause exit handlers + * to be established during Tcl_Finalize processing. Such exit + * handlers leave malloc'ed memory, and Tcl_FinalizeThreadAlloc or + * Tcl_FinalizeMemorySubsystem will result in a corrupted heap. The + * result can be a mysterious crash on process exit. Check here that * nobody's done this. */ - if ( firstExitPtr != NULL ) { - Tcl_Panic( "exit handlers were created during Tcl_Finalize" ); + if (firstExitPtr != NULL) { + Tcl_Panic("exit handlers were created during Tcl_Finalize"); } /* * There shouldn't be any malloc'ed memory after this. */ + TclFinalizePreserve(); #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); @@ -977,8 +971,8 @@ Tcl_Finalize() * * Tcl_FinalizeThread -- * - * Runs the exit handlers to allow Tcl to clean up its state - * about a particular thread. + * Runs the exit handlers to allow Tcl to clean up its state about a + * particular thread. * * Results: * None. @@ -1019,14 +1013,14 @@ Tcl_FinalizeThread() /* * Blow away all thread local storage blocks. * - * Note that Tcl API allows creation of threads which do not use any - * Tcl interp or other Tcl subsytems. Those threads might, however, - * use thread local storage, so we must unconditionally finalize it. + * Note that Tcl API allows creation of threads which do not use any Tcl + * interp or other Tcl subsytems. Those threads might, however, use thread + * local storage, so we must unconditionally finalize it. * * Fix [Bug #571002] */ - TclFinalizeThreadData(); + TclFinalizeThreadData(); } /* @@ -1084,8 +1078,8 @@ TclInThreadExit() * * Tcl_VwaitObjCmd -- * - * This procedure is invoked to process the "vwait" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "vwait" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1108,7 +1102,7 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv) char *nameString; if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "name"); + Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } nameString = Tcl_GetString(objv[1]); @@ -1132,8 +1126,8 @@ Tcl_VwaitObjCmd(clientData, interp, objc, objv) VwaitVarProc, (ClientData) &done); /* - * Clear out the interpreter's result, since it may have been set - * by event handlers. + * Clear out the interpreter's result, since it may have been set by event + * handlers. */ Tcl_ResetResult(interp); @@ -1165,8 +1159,8 @@ VwaitVarProc(clientData, interp, name1, name2, flags) * * Tcl_UpdateObjCmd -- * - * This procedure is invoked to process the "update" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "update" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1198,16 +1192,14 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { - case REGEXP_IDLETASKS: { - flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; - break; - } - default: { - Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); - } + case REGEXP_IDLETASKS: + flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; + break; + default: + Tcl_Panic("Tcl_UpdateObjCmd: bad option index to UpdateOptions"); } } else { - Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); + Tcl_WrongNumArgs(interp, 1, objv, "?idletasks?"); return TCL_ERROR; } @@ -1220,14 +1212,14 @@ Tcl_UpdateObjCmd(clientData, interp, objc, objv) } /* - * Must clear the interpreter's result because event handlers could - * have executed commands. + * Must clear the interpreter's result because event handlers could have + * executed commands. */ Tcl_ResetResult(interp); return TCL_OK; } - + #ifdef TCL_THREADS /* *----------------------------------------------------------------------------- @@ -1262,18 +1254,19 @@ NewThreadProc(ClientData clientData) TCL_THREAD_CREATE_RETURN; } #endif + /* *---------------------------------------------------------------------- * * Tcl_CreateThread -- * - * This procedure creates a new thread. This actually belongs - * to the tclThread.c file but since we use some private - * data structures local to this file, it is placed here. + * This procedure creates a new thread. This actually belongs to the + * tclThread.c file but since we use some private data structures local + * to this file, it is placed here. * * Results: - * TCL_OK if the thread could be created. The thread ID is - * returned in a parameter. + * TCL_OK if the thread could be created. The thread ID is returned in a + * parameter. * * Side effects: * A new thread is created. @@ -1287,19 +1280,27 @@ Tcl_CreateThread(idPtr, proc, clientData, stackSize, flags) Tcl_ThreadCreateProc proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ int stackSize; /* Size of stack for the new thread */ - int flags; /* Flags controlling behaviour of - * the new thread */ + int flags; /* Flags controlling behaviour of the + * new thread. */ { #ifdef TCL_THREADS ThreadClientData *cdPtr; - cdPtr = (ThreadClientData*)Tcl_Alloc(sizeof(ThreadClientData)); + cdPtr = (ThreadClientData *) Tcl_Alloc(sizeof(ThreadClientData)); cdPtr->proc = proc; cdPtr->clientData = clientData; return TclpThreadCreate(idPtr, NewThreadProc, (ClientData)cdPtr, - stackSize, flags); + stackSize, flags); #else return TCL_ERROR; #endif /* TCL_THREADS */ } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 900f121..0bf1754 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -1,16 +1,16 @@ /* * tclFileName.c -- * - * This file contains routines for converting file names betwen - * native and network form. + * This file contains routines for converting file names betwen native + * and network form. * * Copyright (c) 1995-1998 Sun Microsystems, Inc. * Copyright (c) 1998-1999 by Scriptics Corporation. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclFileName.c,v 1.70 2005/06/21 19:20:11 kennykb Exp $ + * RCS: @(#) $Id: tclFileName.c,v 1.71 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" @@ -18,8 +18,8 @@ #include "tclFileSystem.h" /* For TclGetPathType() */ /* - * The following variable is set in the TclPlatformInit call to one - * of: TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. + * The following variable is set in the TclPlatformInit call to one of: + * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS. */ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; @@ -36,25 +36,23 @@ static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, static int SkipToChar _ANSI_ARGS_((char **stringPtr, int match)); static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); -static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, +static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *resultPtr, char *separators, Tcl_Obj *pathPtr, int flags, char *pattern, Tcl_GlobTypeData *types)); - /* *---------------------------------------------------------------------- * * ExtractWinRoot -- * - * Matches the root portion of a Windows path and appends it - * to the specified Tcl_DString. + * Matches the root portion of a Windows path and appends it to the + * specified Tcl_DString. * * Results: - * Returns the position in the path immediately after the root - * including any trailing slashes. - * Appends a cleaned up version of the root to the Tcl_DString - * at the specified offest. + * Returns the position in the path immediately after the root including + * any trailing slashes. Appends a cleaned up version of the root to the + * Tcl_DString at the specified offest. * * Side effects: * Modifies the specified Tcl_DString. @@ -71,9 +69,13 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) Tcl_PathType *typePtr; /* Where to store pathType result */ { if (path[0] == '/' || path[0] == '\\') { - /* Might be a UNC or Vol-Relative path */ + /* + * Might be a UNC or Vol-Relative path. + */ + CONST char *host, *share, *tail; int hlen, slen; + if (path[1] != '/' && path[1] != '\\') { Tcl_DStringSetLength(resultPtr, offset); *typePtr = TCL_PATH_VOLUME_RELATIVE; @@ -82,7 +84,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) } host = &path[2]; - /* Skip separators */ + /* + * Skip separators. + */ + while (host[0] == '/' || host[0] == '\\') { host++; } @@ -94,17 +99,15 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) } if (host[hlen] == 0 || host[hlen+1] == 0) { /* - * The path given is simply of the form - * '/foo', '//foo', '/////foo' or the same - * with backslashes. If there is exactly - * one leading '/' the path is volume relative - * (see filename man page). If there are more - * than one, we are simply assuming they - * are superfluous and we trim them away. - * (An alternative interpretation would - * be that it is a host name, but we have + * The path given is simply of the form '/foo', '//foo', + * '/////foo' or the same with backslashes. If there is exactly + * one leading '/' the path is volume relative (see filename man + * page). If there are more than one, we are simply assuming they + * are superfluous and we trim them away. (An alternative + * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ + *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, "/", 1); return &path[2]; @@ -112,7 +115,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) Tcl_DStringSetLength(resultPtr, offset); share = &host[hlen]; - /* Skip separators */ + /* + * Skip separators. + */ + while (share[0] == '/' || share[0] == '\\') { share++; } @@ -129,7 +135,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) tail = &share[slen]; - /* Skip separators */ + /* + * Skip separators. + */ + while (tail[0] == '/' || tail[0] == '\\') { tail++; } @@ -137,7 +146,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) *typePtr = TCL_PATH_ABSOLUTE; return tail; } else if (*path && path[1] == ':') { - /* Might be a drive sep */ + /* + * Might be a drive separator. + */ + Tcl_DStringSetLength(resultPtr, offset); if (path[2] != '/' && path[2] != '\\') { @@ -147,7 +159,10 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) } else { char *tail = (char*)&path[3]; - /* Skip separators */ + /* + * Skip separators. + */ + while (*tail && (tail[0] == '/' || tail[0] == '\\')) { tail++; } @@ -160,50 +175,78 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) } } else { int abs = 0; - if ((path[0] == 'c' || path[0] == 'C') - && (path[1] == 'o' || path[1] == 'O')) { + + /* + * Check for Windows devices. + */ + + if ((path[0] == 'c' || path[0] == 'C') + && (path[1] == 'o' || path[1] == 'O')) { if ((path[2] == 'm' || path[2] == 'M') - && path[3] >= '1' && path[3] <= '4') { - /* May have match for 'com[1-4]:?', which is a serial port */ + && path[3] >= '1' && path[3] <= '4') { + /* + * May have match for 'com[1-4]:?', which is a serial port. + */ + if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } + } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') { - /* Have match for 'con' */ + /* + * Have match for 'con'. + */ + abs = 3; } + } else if ((path[0] == 'l' || path[0] == 'L') - && (path[1] == 'p' || path[1] == 'P') - && (path[2] == 't' || path[2] == 'T')) { + && (path[1] == 'p' || path[1] == 'P') + && (path[2] == 't' || path[2] == 'T')) { if (path[3] >= '1' && path[3] <= '3') { - /* May have match for 'lpt[1-3]:?' */ + /* + * May have match for 'lpt[1-3]:?' + */ + if (path[4] == '\0') { abs = 4; } else if (path [4] == ':' && path[5] == '\0') { abs = 5; } } + } else if ((path[0] == 'p' || path[0] == 'P') - && (path[1] == 'r' || path[1] == 'R') - && (path[2] == 'n' || path[2] == 'N') - && path[3] == '\0') { - /* Have match for 'prn' */ + && (path[1] == 'r' || path[1] == 'R') + && (path[2] == 'n' || path[2] == 'N') + && path[3] == '\0') { + /* + * Have match for 'prn'. + */ abs = 3; + } else if ((path[0] == 'n' || path[0] == 'N') - && (path[1] == 'u' || path[1] == 'U') - && (path[2] == 'l' || path[2] == 'L') - && path[3] == '\0') { - /* Have match for 'nul' */ + && (path[1] == 'u' || path[1] == 'U') + && (path[2] == 'l' || path[2] == 'L') + && path[3] == '\0') { + /* + * Have match for 'nul'. + */ + abs = 3; + } else if ((path[0] == 'a' || path[0] == 'A') - && (path[1] == 'u' || path[1] == 'U') - && (path[2] == 'x' || path[2] == 'X') - && path[3] == '\0') { - /* Have match for 'aux' */ + && (path[1] == 'u' || path[1] == 'U') + && (path[2] == 'x' || path[2] == 'X') + && path[3] == '\0') { + /* + * Have match for 'aux'. + */ + abs = 3; } + if (abs != 0) { *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringSetLength(resultPtr, offset); @@ -211,7 +254,11 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) return path + abs; } } - /* Anything else is treated as relative */ + + /* + * Anything else is treated as relative. + */ + *typePtr = TCL_PATH_RELATIVE; return path; } @@ -221,12 +268,12 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * * Tcl_GetPathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute. * - * The objectified Tcl_FSGetPathType should be used in - * preference to this function (as you can see below, this - * is just a wrapper around that other function). + * The objectified Tcl_FSGetPathType should be used in preference to this + * function (as you can see below, this is just a wrapper around that + * other function). * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -244,6 +291,7 @@ Tcl_GetPathType(path) { Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(tempObj); type = Tcl_FSGetPathType(tempObj); Tcl_DecrRefCount(tempObj); @@ -255,18 +303,18 @@ Tcl_GetPathType(path) * * TclpGetNativePathType -- * - * Determines whether a given path is relative to the current - * directory, relative to the current volume, or absolute, but - * ONLY FOR THE NATIVE FILESYSTEM. This function is called from - * tclIOUtil.c (but needs to be here due to its dependence on - * static variables/functions in this file). The exported - * function Tcl_FSGetPathType should be used by extensions. + * Determines whether a given path is relative to the current directory, + * relative to the current volume, or absolute, but ONLY FOR THE NATIVE + * FILESYSTEM. This function is called from tclIOUtil.c (but needs to be + * here due to its dependence on static variables/functions in this + * file). The exported function Tcl_FSGetPathType should be used by + * extensions. * - * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, - * even though expanding the '~' could lead to any possible - * path type. This function should therefore be considered a - * low-level, string-manipulation function only -- it doesn't - * actually do any expansion in making its determination. + * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even + * though expanding the '~' could lead to any possible path type. This + * function should therefore be considered a low-level, string + * manipulation function only -- it doesn't actually do any expansion in + * making its determination. * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or @@ -280,9 +328,9 @@ Tcl_GetPathType(path) Tcl_PathType TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Native path of interest */ - int *driveNameLengthPtr; /* Returns length of drive, if non-NULL - * and path was absolute */ + Tcl_Obj *pathPtr; /* Native path of interest */ + int *driveNameLengthPtr; /* Returns length of drive, if non-NULL and + * path was absolute */ Tcl_Obj **driveNameRef; { Tcl_PathType type = TCL_PATH_ABSOLUTE; @@ -291,9 +339,10 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) if (path[0] == '~') { /* - * This case is common to all platforms. - * Paths that begin with ~ are absolute. + * This case is common to all platforms. Paths that begin with ~ are + * absolute. */ + if (driveNameLengthPtr != NULL) { char *end = path + 1; while ((*end != '\0') && (*end != '/')) { @@ -325,9 +374,9 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX code - * was used + * We need this addition in case the QNX code was used. */ + *driveNameLengthPtr = (1 + path - origPath); } } else { @@ -362,18 +411,17 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) * * TclpNativeSplitPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * path, and returns a Tcl List object containing each segment - * of that path as an element. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * - * Note this function currently calls the older Split(Plat)Path - * functions, which require more memory allocation than is - * desirable. + * Note this function currently calls the older Split(Plat)Path + * functions, which require more memory allocation than is desirable. * * Results: - * Returns list object with refCount of zero. If the passed in - * lenPtr is non-NULL, we use it to return the number of elements - * in the returned list. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: * None. @@ -417,20 +465,19 @@ TclpNativeSplitPath(pathPtr, lenPtr) * * Tcl_SplitPath -- * - * Split a path into a list of path components. The first element - * of the list will have the same path type as the original path. + * Split a path into a list of path components. The first element of the + * list will have the same path type as the original path. * * Results: - * Returns a standard Tcl result. The interpreter result contains - * a list of path components. - * *argvPtr will be filled in with the address of an array - * whose elements point to the elements of path, 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 path elements. - * The caller must eventually free this memory by calling ckfree() - * on *argvPtr. Note: *argvPtr and *argcPtr are only modified - * if the procedure returns normally. + * Returns a standard Tcl result. The interpreter result contains a list + * of path components. *argvPtr will be filled in with the address of an + * array whose elements point to the elements of path, 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 path elements. The caller must + * eventually free this memory by calling ckfree() on *argvPtr. Note: + * *argvPtr and *argcPtr are only modified if the procedure returns + * normally. * * Side effects: * Allocates memory. @@ -441,8 +488,8 @@ TclpNativeSplitPath(pathPtr, lenPtr) void Tcl_SplitPath(path, argcPtr, argvPtr) CONST char *path; /* Pointer to string containing a path. */ - int *argcPtr; /* Pointer to location to fill in with - * the number of elements in the path. */ + int *argcPtr; /* Pointer to location to fill in with the + * number of elements in the path. */ CONST char ***argvPtr; /* Pointer to place to store pointer to array * of pointers to path elements. */ { @@ -461,7 +508,9 @@ Tcl_SplitPath(path, argcPtr, argvPtr) Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(tmpPtr); - /* Calculate space required for the result */ + /* + * Calculate space required for the result. + */ size = 1; for (i = 0; i < *argcPtr; i++) { @@ -471,16 +520,16 @@ Tcl_SplitPath(path, argcPtr, argvPtr) } /* - * Allocate a buffer large enough to hold the contents of all of - * the list plus the argv pointers and the terminating NULL pointer. + * Allocate a buffer large enough to hold the contents of all of the list + * plus the argv pointers and the terminating NULL pointer. */ *argvPtr = (CONST char **) ckalloc((unsigned) ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* - * Position p after the last argv pointer and copy the contents of - * the list in, piece by piece. + * Position p after the last argv pointer and copy the contents of the + * list in, piece by piece. */ p = (char *) &(*argvPtr)[(*argcPtr) + 1]; @@ -515,8 +564,8 @@ Tcl_SplitPath(path, argcPtr, argvPtr) * * SplitUnixPath -- * - * This routine is used by Tcl_(FS)SplitPath to handle splitting - * Unix paths. + * This routine is used by Tcl_(FS)SplitPath to handle splitting Unix + * paths. * * Results: * Returns a newly allocated Tcl list object. @@ -586,15 +635,14 @@ SplitUnixPath(path) } return result; } - /* *---------------------------------------------------------------------- * * SplitWinPath -- * - * This routine is used by Tcl_(FS)SplitPath to handle splitting - * Windows paths. + * This routine is used by Tcl_(FS)SplitPath to handle splitting Windows + * paths. * * Results: * Returns a newly allocated Tcl list object. @@ -629,9 +677,9 @@ SplitWinPath(path) Tcl_DStringFree(&buf); /* - * Split on slashes. Embedded elements that start with tilde - * or a drive letter will be prefixed with "./" so they are not - * affected by tilde substitution. + * Split on slashes. Embedded elements that start with tilde or a drive + * letter will be prefixed with "./" so they are not affected by tilde + * substitution. */ do { @@ -663,18 +711,17 @@ SplitWinPath(path) * * Tcl_FSJoinToPath -- * - * This function takes the given object, which should usually be a - * valid path or NULL, and joins onto it the array of paths - * segments given. + * This function takes the given object, which should usually be a valid + * path or NULL, and joins onto it the array of paths segments given. * - * The objects in the array given will temporarily have their - * refCount increased by one, and then decreased by one when this - * function exits (which means if they had zero refCount when we - * were called, they will be freed). + * The objects in the array given will temporarily have their refCount + * increased by one, and then decreased by one when this function exits + * (which means if they had zero refCount when we were called, they will + * be freed). * * Results: - * Returns object owned by the caller (which should increment its - * refCount) - typically an object with refCount of zero. + * Returns object owned by the caller (which should increment its + * refCount) - typically an object with refCount of zero. * * Side effects: * None. @@ -682,11 +729,11 @@ SplitWinPath(path) *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj * Tcl_FSJoinToPath(pathPtr, objc, objv) - Tcl_Obj *pathPtr; /* Valid path or NULL. */ - int objc; /* Number of array elements to join */ - Tcl_Obj *CONST objv[]; /* Path elements to join. */ + Tcl_Obj *pathPtr; /* Valid path or NULL. */ + int objc; /* Number of array elements to join */ + Tcl_Obj *CONST objv[]; /* Path elements to join. */ { int i; Tcl_Obj *lobj, *ret; @@ -701,14 +748,15 @@ Tcl_FSJoinToPath(pathPtr, objc, objv) Tcl_ListObjAppendElement(NULL, lobj, objv[i]); } ret = Tcl_FSJoinPath(lobj, -1); + /* - * It is possible that 'ret' is just a member of the list and is - * therefore going to be freed here. Therefore we must adjust the - * refCount manually. (It would be better if we changed the - * documentation of this function and Tcl_FSJoinPath so that - * the returned object already has a refCount for the caller, - * hence avoiding these subtleties (and code ugliness)). + * It is possible that 'ret' is just a member of the list and is therefore + * going to be freed here. Therefore we must adjust the refCount manually. + * (It would be better if we changed the documentation of this function + * and Tcl_FSJoinPath so that the returned object already has a refCount + * for the caller, hence avoiding these subtleties (and code ugliness)). */ + Tcl_IncrRefCount(ret); Tcl_DecrRefCount(lobj); ret->refCount--; @@ -720,10 +768,10 @@ Tcl_FSJoinToPath(pathPtr, objc, objv) * * TclpNativeJoinPath -- * - * 'prefix' is absolute, 'joining' is relative to prefix. + * 'prefix' is absolute, 'joining' is relative to prefix. * * Results: - * modifies prefix + * modifies prefix * * Side effects: * None. @@ -734,7 +782,7 @@ Tcl_FSJoinToPath(pathPtr, objc, objv) void TclpNativeJoinPath(prefix, joining) Tcl_Obj *prefix; - char* joining; + char *joining; { int length, needsSep; char *dest, *p, *start; @@ -742,18 +790,16 @@ TclpNativeJoinPath(prefix, joining) start = Tcl_GetStringFromObj(prefix, &length); /* - * Remove the ./ from tilde prefixed elements, and drive-letter - * prefixed elements on Windows, unless it is the first component. + * Remove the ./ from tilde prefixed elements, and drive-letter prefixed + * elements on Windows, unless it is the first component. */ p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') - && ((p[2] == '~') - || ((tclPlatform == TCL_PLATFORM_WINDOWS) - && isalpha(UCHAR(p[2])) - && (p[3] == ':')))) { + if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') + || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) + && (p[3] == ':')))) { p += 2; } } @@ -774,8 +820,7 @@ TclpNativeJoinPath(prefix, joining) needsSep = 0; /* - * Append the element, eliminating duplicate and trailing - * slashes. + * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); @@ -811,8 +856,7 @@ TclpNativeJoinPath(prefix, joining) needsSep = 0; /* - * Append the element, eliminating duplicate and - * trailing slashes. + * Append the element, eliminating duplicate and trailing slashes. */ Tcl_SetObjLength(prefix, length + (int) strlen(p)); @@ -842,14 +886,13 @@ TclpNativeJoinPath(prefix, joining) * * Tcl_JoinPath -- * - * Combine a list of paths in a platform specific manner. The - * function 'Tcl_FSJoinPath' should be used in preference where - * possible. + * Combine a list of paths in a platform specific manner. The function + * 'Tcl_FSJoinPath' should be used in preference where possible. * * Results: - * Appends the joined path to the end of the specified - * Tcl_DString returning a pointer to the resulting string. Note - * that the Tcl_DString must already be initialized. + * Appends the joined path to the end of the specified Tcl_DString + * returning a pointer to the resulting string. Note that the + * Tcl_DString must already be initialized. * * Side effects: * Modifies the Tcl_DString. @@ -868,24 +911,36 @@ Tcl_JoinPath(argc, argv, resultPtr) Tcl_Obj *resultObj; char *resultStr; - /* Build the list of paths */ + /* + * Build the list of paths. + */ + for (i = 0; i < argc; i++) { - Tcl_ListObjAppendElement(NULL, listObj, + Tcl_ListObjAppendElement(NULL, listObj, Tcl_NewStringObj(argv[i], -1)); } - /* Ask the objectified code to join the paths */ + /* + * Ask the objectified code to join the paths. + */ + Tcl_IncrRefCount(listObj); resultObj = Tcl_FSJoinPath(listObj, argc); Tcl_IncrRefCount(resultObj); Tcl_DecrRefCount(listObj); - /* Store the result */ + /* + * Store the result. + */ + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); - /* Return a pointer to the result */ + /* + * Return a pointer to the result. + */ + return Tcl_DStringValue(resultPtr); } @@ -895,19 +950,19 @@ Tcl_JoinPath(argc, argv, resultPtr) * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce a - * name where the tilde and following characters have been replaced - * by the home directory location for the named user. + * interfaces. If the name starts with a tilde, it will produce a name + * where the tilde and following characters have been replaced by the + * home directory location for the named user. * * Results: - * The return value is a pointer to a string containing the name - * after tilde substitution. If there was no tilde substitution, - * the return value is a pointer to a copy of the original string. - * If there was an error in processing the name, then an error - * message is left in the interp's result (if interp was not NULL) - * and the return value is NULL. Space for the return value is - * allocated in bufferPtr; the caller must call Tcl_DStringFree() - * to free the space if the return value was not NULL. + * The return value is a pointer to a string containing the name after + * tilde substitution. If there was no tilde substitution, the return + * value is a pointer to a copy of the original string. If there was an + * error in processing the name, then an error message is left in the + * interp's result (if interp was not NULL) and the return value is NULL. + * Space for the return value is allocated in bufferPtr; the caller must + * call Tcl_DStringFree() to free the space if the return value was not + * NULL. * * Side effects: * None. @@ -917,14 +972,14 @@ Tcl_JoinPath(argc, argv, resultPtr) char * Tcl_TranslateFileName(interp, name, bufferPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ CONST char *name; /* File name, which may begin with "~" (to * indicate current user's home directory) or * "~" (to indicate any user's home * directory). */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled - * with name after tilde substitution. */ + Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + * name after tilde substitution. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; @@ -942,8 +997,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr) Tcl_DecrRefCount(transPtr); /* - * Convert forward slashes to backslashes in Windows paths because - * some system interfaces don't accept forward slashes. + * Convert forward slashes to backslashes in Windows paths because some + * system interfaces don't accept forward slashes. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { @@ -954,6 +1009,7 @@ Tcl_TranslateFileName(interp, name, bufferPtr) } } } + return Tcl_DStringValue(bufferPtr); } @@ -962,8 +1018,8 @@ Tcl_TranslateFileName(interp, name, bufferPtr) * * TclGetExtension -- * - * This function returns a pointer to the beginning of the - * extension part of a file name. + * This function returns a pointer to the beginning of the extension part + * of a file name. * * Results: * Returns a pointer into name which indicates where the extension @@ -1025,11 +1081,10 @@ TclGetExtension(name) * * Results: * The result is a pointer to a static string containing the home - * directory in native format. If there was an error in processing - * the substitution, then an error message is left in the interp's - * result and the return value is NULL. On success, the results - * are appended to resultPtr, and the contents of resultPtr are - * returned. + * directory in native format. If there was an error in processing the + * substitution, then an error message is left in the interp's result and + * the return value is NULL. On success, the results are appended to + * resultPtr, and the contents of resultPtr are returned. * * Side effects: * Information may be left in resultPtr. @@ -1039,12 +1094,12 @@ TclGetExtension(name) static CONST char * DoTildeSubst(interp, user, resultPtr) - Tcl_Interp *interp; /* Interpreter in which to store error - * message (if necessary). */ + Tcl_Interp *interp; /* Interpreter in which to store error message + * (if necessary). */ CONST char *user; /* Name of user whose home directory should be * substituted, or "" for current user. */ - Tcl_DString *resultPtr; /* Initialized DString filled with name - * after tilde substitution. */ + Tcl_DString *resultPtr; /* Initialized DString filled with name after + * tilde substitution. */ { CONST char *dir; @@ -1078,8 +1133,8 @@ DoTildeSubst(interp, user, resultPtr) * * Tcl_GlobObjCmd -- * - * This procedure is invoked to process the "glob" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "glob" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1124,19 +1179,22 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* - * It looks like the command contains an option so signal - * an error + * It looks like the command contains an option so signal an + * error. */ + return TCL_ERROR; } else { /* - * This clearly isn't an option; assume it's the first - * glob pattern. We must clear the error + * This clearly isn't an option; assume it's the first glob + * pattern. We must clear the error. */ + Tcl_ResetResult(interp); break; } } + switch (index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ globFlags |= TCL_GLOBMODE_NO_COMPLAIN; @@ -1195,13 +1253,14 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) goto endOfForLoop; } } + endOfForLoop: if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); return TCL_ERROR; } if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, + Tcl_AppendResult(interp, "\"-tails\" must be used with either ", "\"-directory\" or \"-path\"", NULL); return TCL_ERROR; @@ -1216,6 +1275,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) separators = "/\\:"; break; } + if (dir == PATH_GENERAL) { int pathlength; char *last; @@ -1224,46 +1284,60 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) /* * Find the last path separator in the path */ + last = first + pathlength; for (; last != first; last--) { if (strchr(separators, *(last-1)) != NULL) { break; } } + if (last == first + pathlength) { - /* It's really a directory */ + /* + * It's really a directory. + */ + dir = PATH_DIR; + } else { Tcl_DString pref; char *search, *find; Tcl_DStringInit(&pref); if (last == first) { /* - * The whole thing is a prefix. This means we must - * remove any 'tails' flag too, since it is irrelevant - * now (the same effect will happen without it), but in - * particular its use in TclGlob requires a non-NULL - * pathOrDir. + * The whole thing is a prefix. This means we must remove any + * 'tails' flag too, since it is irrelevant now (the same + * effect will happen without it), but in particular its use + * in TclGlob requires a non-NULL pathOrDir. */ + Tcl_DStringAppend(&pref, first, -1); globFlags &= ~TCL_GLOBMODE_TAILS; pathOrDir = NULL; } else { - /* Have to split off the end */ + /* + * Have to split off the end. + */ + Tcl_DStringAppend(&pref, last, first+pathlength-last); pathOrDir = Tcl_NewStringObj(first, last-first-1); + /* - * We must ensure that we haven't cut off too much, - * and turned a valid path like '/' or 'C:/' into - * an incorrect path like '' or 'C:'. The way we - * do this is to add a separator if there are none - * presently in the prefix. + * We must ensure that we haven't cut off too much, and turned + * a valid path like '/' or 'C:/' into an incorrect path like + * '' or 'C:'. The way we do this is to add a separator if + * there are none presently in the prefix. */ + if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) { Tcl_AppendToObj(pathOrDir, last-1, 1); } } - /* Need to quote 'prefix' */ + + /* + * Need to quote 'prefix'. + */ + Tcl_DStringInit(&prefix); search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { @@ -1288,19 +1362,22 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (typePtr != NULL) { /* - * The rest of the possible type arguments (except 'd') are - * platform specific. We don't complain when they are used - * on an incompatible platform. + * The rest of the possible type arguments (except 'd') are platform + * specific. We don't complain when they are used on an incompatible + * platform. */ + Tcl_ListObjLength(interp, typePtr, &length); globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; globTypes->macCreator = NULL; + while (--length >= 0) { int len; char *str; + Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { @@ -1342,15 +1419,21 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) default: goto badTypesArg; } + } else if (len == 4) { - /* This is assumed to be a MacOS file type */ + /* + * This is assumed to be a MacOS file type. + */ + if (globTypes->macType != NULL) { goto badMacTypesArg; } globTypes->macType = look; Tcl_IncrRefCount(look); + } else { Tcl_Obj* item; + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); @@ -1375,12 +1458,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } } } + /* - * Error cases. We reset - * the 'join' flag to zero, since we haven't yet - * made use of it. + * Error cases. We reset the 'join' flag to zero, since we + * haven't yet made use of it. */ - badTypesArg: + + badTypesArg: TclNewObj(resultPtr); Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); Tcl_AppendObjToObj(resultPtr, look); @@ -1388,7 +1472,8 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) result = TCL_ERROR; join = 0; goto endOfGlob; - badMacTypesArg: + + badMacTypesArg: Tcl_SetObjResult(interp, Tcl_NewStringObj( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); @@ -1400,14 +1485,15 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } /* - * Now we perform the actual glob below. This may involve joining - * together the pattern arguments, dealing with particular file types - * etc. We use a 'goto' to ensure we free any memory allocated along - * the way. + * Now we perform the actual glob below. This may involve joining together + * the pattern arguments, dealing with particular file types etc. We use a + * 'goto' to ensure we free any memory allocated along the way. */ + objc -= i; objv += i; result = TCL_OK; + if (join) { if (dir != PATH_GENERAL) { Tcl_DStringInit(&prefix); @@ -1419,48 +1505,52 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_DStringAppend(&prefix, separators, 1); } } - if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, - globFlags, globTypes) != TCL_OK) { + if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags, + globTypes) != TCL_OK) { result = TCL_ERROR; goto endOfGlob; } - } else { - if (dir == PATH_GENERAL) { - Tcl_DString str; - for (i = 0; i < objc; i++) { - Tcl_DStringInit(&str); - if (dir == PATH_GENERAL) { - Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), - Tcl_DStringLength(&prefix)); - } - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&str, string, length); - if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, - globFlags, globTypes) != TCL_OK) { - result = TCL_ERROR; - Tcl_DStringFree(&str); - goto endOfGlob; - } + } else if (dir == PATH_GENERAL) { + Tcl_DString str; + + for (i = 0; i < objc; i++) { + Tcl_DStringInit(&str); + if (dir == PATH_GENERAL) { + Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), + Tcl_DStringLength(&prefix)); } - Tcl_DStringFree(&str); - } else { - for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - if (TclGlob(interp, string, pathOrDir, - globFlags, globTypes) != TCL_OK) { - result = TCL_ERROR; - goto endOfGlob; - } + string = Tcl_GetStringFromObj(objv[i], &length); + Tcl_DStringAppend(&str, string, length); + if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, + globTypes) != TCL_OK) { + result = TCL_ERROR; + Tcl_DStringFree(&str); + goto endOfGlob; + } + } + Tcl_DStringFree(&str); + } else { + for (i = 0; i < objc; i++) { + string = Tcl_GetString(objv[i]); + if (TclGlob(interp, string, pathOrDir, globFlags, + globTypes) != TCL_OK) { + result = TCL_ERROR; + goto endOfGlob; } } } + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { - /* This should never happen. Maybe we should be more dramatic */ + /* + * This should never happen. Maybe we should be more dramatic. + */ + result = TCL_ERROR; goto endOfGlob; } + if (length == 0) { Tcl_AppendResult(interp, "no files matched glob pattern", (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL); @@ -1479,6 +1569,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) result = TCL_ERROR; } } + endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); @@ -1503,28 +1594,26 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * * TclGlob -- * - * This procedure prepares arguments for the DoGlob call. - * It sets the separator string based on the platform, performs - * tilde substitution, and calls DoGlob. + * This procedure prepares arguments for the DoGlob call. It sets the + * separator string based on the platform, performs * tilde substitution, + * and calls DoGlob. * - * The interpreter's result, on entry to this function, must - * be a valid Tcl list (e.g. it could be empty), since we will - * lappend any new results to that list. If it is not a valid - * list, this function will fail to do anything very meaningful. + * The interpreter's result, on entry to this function, must be a valid + * Tcl list (e.g. it could be empty), since we will lappend any new + * results to that list. If it is not a valid list, this function will + * fail to do anything very meaningful. * - * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then - * pathPrefix cannot be NULL (it is only allowed with -dir or - * -path). + * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix + * cannot be NULL (it is only allowed with -dir or -path). * * Results: - * The return value is a standard Tcl result indicating whether - * an error occurred in globbing. After a normal return the - * result in interp (set by DoGlob) holds all of the file names - * given by the pattern and pathPrefix arguments. After an - * error the result in interp will hold an error message, unless - * the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case - * an error results in a TCL_OK return leaving the interpreter's - * result unmodified. + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. After a normal return the result in interp (set + * by DoGlob) holds all of the file names given by the pattern and + * pathPrefix arguments. After an error the result in interp will hold + * an error message, unless the 'TCL_GLOBMODE_NO_COMPLAIN' flag was + * given, in which case an error results in a TCL_OK return leaving the + * interpreter's result unmodified. * * Side effects: * The 'pattern' is written to. @@ -1535,15 +1624,15 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int TclGlob(interp, pattern, pathPrefix, globFlags, types) - Tcl_Interp *interp; /* Interpreter for returning error message - * or appending list of matching file names. */ - char *pattern; /* Glob pattern to match. Must not refer - * to a static string. */ + Tcl_Interp *interp; /* Interpreter for returning error message or + * appending list of matching file names. */ + char *pattern; /* Glob pattern to match. Must not refer to a + * static string. */ Tcl_Obj *pathPrefix; /* Path prefix to glob pattern, if non-null, - * which is considered literally. */ + * which is considered literally. */ int globFlags; /* Stores or'ed combination of flags */ - Tcl_GlobTypeData *types; /* Struct containing acceptable types. - * May be NULL. */ + Tcl_GlobTypeData *types; /* Struct containing acceptable types. May be + * NULL. */ { char *separators; CONST char *head; @@ -1567,15 +1656,16 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_DStringInit(&buffer); start = pattern; + /* * Perform tilde substitution, if needed. */ if (start[0] == '~') { - /* * Find the first path separator after the tilde. */ + for (tail = start; *tail != '\0'; tail++) { if (*tail == '\\') { if (strchr(separators, tail[1]) != NULL) { @@ -1594,8 +1684,8 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) *tail = '\0'; if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { /* - * We will ignore any error message here, and we - * don't want to mess up the interpreter's result. + * We will ignore any error message here, and we don't want to + * mess up the interpreter's result. */ head = DoTildeSubst(NULL, start+1, &buffer); } else { @@ -1613,7 +1703,7 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_DStringAppend(&buffer, head, -1); } pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), - Tcl_DStringLength(&buffer)); + Tcl_DStringLength(&buffer)); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { @@ -1630,13 +1720,12 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) /* * Handling empty path prefixes with glob patterns like 'C:' or - * 'c:////////' is a pain on Windows if we leave it too late, since - * these aren't really patterns at all! We therefore check the head - * of the pattern now for such cases, if we don't have an unquoted - * prefix yet. + * 'c:////////' is a pain on Windows if we leave it too late, since these + * aren't really patterns at all! We therefore check the head of the + * pattern now for such cases, if we don't have an unquoted prefix yet. * - * Similarly on Unix with '/' at the head of the pattern -- it - * just indicates the root volume, so we treat it as such. + * Similarly on Unix with '/' at the head of the pattern -- it just + * indicates the root volume, so we treat it as such. */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { @@ -1666,20 +1755,21 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { - int driveNameLen; - Tcl_Obj *driveName; - Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); - Tcl_IncrRefCount(temp); + int driveNameLen; + Tcl_Obj *driveName; + Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); + Tcl_IncrRefCount(temp); - switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) { + switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) { case TCL_PATH_VOLUME_RELATIVE: { /* - * Volume relative path which is equivalent to a path in - * the root of the cwd's volume. We will actually return + * Volume relative path which is equivalent to a path in the + * root of the cwd's volume. We will actually return * non-volume-relative paths here. i.e. 'glob /foo*' will - * return 'C:/foobar'. This is much the same as globbing - * for a path with '\\' will return one with '/' on Windows. + * return 'C:/foobar'. This is much the same as globbing for + * a path with '\\' will return one with '/' on Windows. */ + Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { @@ -1702,24 +1792,27 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) } case TCL_PATH_ABSOLUTE: /* - * Absolute, possibly network path //Machine/Share. - * Use that as the path prefix (it already has a - * refCount). + * Absolute, possibly network path //Machine/Share. Use that + * as the path prefix (it already has a refCount). */ + pathPrefix = driveName; tail += driveNameLen; break; case TCL_PATH_RELATIVE: /* Do nothing */ break; - } - Tcl_DecrRefCount(temp); + } + Tcl_DecrRefCount(temp); } + /* - * ':' no longer needed as a separator. It is only relevant - * to the beginning of the path. + * ':' no longer needed as a separator. It is only relevant to the + * beginning of the path. */ + separators = "/\\"; + } else if (tclPlatform == TCL_PLATFORM_UNIX) { if (pathPrefix == NULL && tail[0] == '/') { pathPrefix = Tcl_NewStringObj(tail, 1); @@ -1729,8 +1822,8 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) } /* - * Finally if we still haven't managed to generate a path - * prefix, check if the path starts with a current volume. + * Finally if we still haven't managed to generate a path prefix, check if + * the path starts with a current volume. */ if (pathPrefix == NULL) { @@ -1744,10 +1837,10 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) } /* - * To process a [glob] invokation, this function may be called - * multiple times. Each time, the previously discovered filenames - * are in the interpreter result. We stash that away here so the - * result is free for error messsages. + * To process a [glob] invokation, this function may be called multiple + * times. Each time, the previously discovered filenames are in the + * interpreter result. We stash that away here so the result is free for + * error messsages. */ savedResultObj = Tcl_GetObjResult(interp); @@ -1756,8 +1849,8 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) TclNewObj(filenamesObj); /* - * Now we do the actual globbing, adding filenames as we go to - * buffer in filenamesObj + * Now we do the actual globbing, adding filenames as we go to buffer in + * filenamesObj */ if (*tail == '\0' && pathPrefix != NULL) { @@ -1787,13 +1880,12 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) } /* - * If we only want the tails, we must strip off the prefix now. - * It may seem more efficient to pass the tails flag down into - * DoGlob, Tcl_FSMatchInDirectory, but those functions are - * continually adjusting the prefix as the various pieces of - * the pattern are assimilated, so that would add a lot of - * complexity to the code. This way is a little slower (when - * the -tails flag is given), but much simpler to code. + * If we only want the tails, we must strip off the prefix now. It may + * seem more efficient to pass the tails flag down into DoGlob, + * Tcl_FSMatchInDirectory, but those functions are continually adjusting + * the prefix as the various pieces of the pattern are assimilated, so + * that would add a lot of complexity to the code. This way is a little + * slower (when the -tails flag is given), but much simpler to code. * * We do it by rewriting the result list in-place. */ @@ -1803,21 +1895,21 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_Obj **objv; int prefixLen; - /* If this length has never been set, set it here */ + /* + * If this length has never been set, set it here. + */ + CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); - if (prefixLen > 0 - && (strchr(separators, pre[prefixLen-1]) == NULL)) { - - /* - * If we're on Windows and the prefix is a volume - * relative one like 'C:', then there won't be - * a path separator in between, so no need to - * skip it here. + if (prefixLen > 0 + && (strchr(separators, pre[prefixLen-1]) == NULL)) { + /* + * If we're on Windows and the prefix is a volume relative one + * like 'C:', then there won't be a path separator in between, so + * no need to skip it here. */ - - if ((tclPlatform != TCL_PLATFORM_WINDOWS) - || (prefixLen != 2) - || (pre[1] != ':')) { + + if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2) + || (pre[1] != ':')) { prefixLen++; } } @@ -1836,18 +1928,16 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) elems[0] = Tcl_NewStringObj("/", 1); } } else { - elems[0] = Tcl_NewStringObj(oldStr + prefixLen, - len - prefixLen); + elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); } } /* - * Now we have a list of discovered filenames in filenamesObj and - * a list of previously discovered (saved earlier from the - * interpreter result) in savedResultObj. Merge them and put them - * back in the interpreter result. + * Now we have a list of discovered filenames in filenamesObj and a list + * of previously discovered (saved earlier from the interpreter result) in + * savedResultObj. Merge them and put them back in the interpreter result. */ if (Tcl_IsShared(savedResultObj)) { @@ -1871,14 +1961,13 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) * * SkipToChar -- * - * This function traverses a glob pattern looking for the next - * unquoted occurance of the specified character at the same braces - * nesting level. + * This function traverses a glob pattern looking for the next unquoted + * occurance of the specified character at the same braces nesting level. * * Results: - * Updates stringPtr to point to the matching character, or to - * the end of the string if nothing matched. The return value - * is 1 if a match was found at the top level, otherwise it is 0. + * Updates stringPtr to point to the matching character, or to the end of + * the string if nothing matched. The return value is 1 if a match was + * found at the top level, otherwise it is 0. * * Side effects: * None. @@ -1923,22 +2012,21 @@ SkipToChar(stringPtr, match) * * DoGlob -- * - * This recursive procedure forms the heart of the globbing code. - * It performs a depth-first traversal of the tree given by the - * path name to be globbed and the pattern. The directory and - * remainder are assumed to be native format paths. The prefix - * contained in 'pathPtr' is either a directory or path from which - * to start the search (or NULL). If pathPtr is NULL, then the - * pattern must not start with an absolute path specification - * (that case should be handled by moving the absolute path + * This recursive procedure forms the heart of the globbing code. It + * performs a depth-first traversal of the tree given by the path name to + * be globbed and the pattern. The directory and remainder are assumed to + * be native format paths. The prefix contained in 'pathPtr' is either a + * directory or path from which to start the search (or NULL). If pathPtr + * is NULL, then the pattern must not start with an absolute path + * specification (that case should be handled by moving the absolute path * prefix into pathPtr before calling DoGlob). * * Results: - * The return value is a standard Tcl result indicating whether - * an error occurred in globbing. After a normal return the - * result in interp will be set to hold all of the file names - * given by the dir and remaining arguments. After an error the - * result in interp will hold an error message. + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. After a normal return the result in interp will + * be set to hold all of the file names given by the dir and remaining + * arguments. After an error the result in interp will hold an error + * message. * * Side effects: * None. @@ -1954,14 +2042,13 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ - char *separators; /* String containing separator characters - * that should be used to identify globbing + char *separators; /* String containing separator characters that + * should be used to identify globbing * boundaries. */ - Tcl_Obj *pathPtr; /* Completely expanded prefix. */ - int flags; /* If non-zero then pathPtr is a - * directory */ - char *pattern; /* The pattern to match against. - * Must not be a pointer to a static string. */ + Tcl_Obj *pathPtr; /* Completely expanded prefix. */ + int flags; /* If non-zero then pathPtr is a directory */ + char *pattern; /* The pattern to match against. Must not be + * a pointer to a static string. */ Tcl_GlobTypeData *types; /* List object containing list of acceptable * types. May be NULL. */ { @@ -1971,8 +2058,8 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_Obj *joinedPtr; /* - * Consume any leading directory separators, leaving pattern pointing - * just past the last initial separator. + * Consume any leading directory separators, leaving pattern pointing just + * past the last initial separator. */ count = 0; @@ -1982,10 +2069,11 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) /* * If the first character is escaped, either we have a directory * separator, or we have any other character. In the latter case - * the rest is a pattern, and we must break from the loop. - * This is particularly important on Windows where '\' is both - * the escaping character and a directory separator. + * the rest is a pattern, and we must break from the loop. This + * is particularly important on Windows where '\' is both the + * escaping character and a directory separator. */ + if (strchr(separators, pattern[1]) != NULL) { pattern++; } else { @@ -1998,22 +2086,23 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } /* - * This block of code is not exercised by the Tcl test suite as of - * Tcl 8.5a0. Simplifications to the calling paths suggest it may - * not be necessary any more, since path separators are handled - * elsewhere. It is left in place in case new bugs are reported + * This block of code is not exercised by the Tcl test suite as of Tcl + * 8.5a0. Simplifications to the calling paths suggest it may not be + * necessary any more, since path separators are handled elsewhere. It is + * left in place in case new bugs are reported */ #if 0 /* PROBABLY_OBSOLETE */ /* * Deal with path separators. */ + if (pathPtr == NULL) { /* - * Length used to be the length of the prefix, and lastChar - * the lastChar of the prefix. But, none of this is used - * any more. + * Length used to be the length of the prefix, and lastChar the + * lastChar of the prefix. But, none of this is used any more. */ + int length = 0; char lastChar = 0; @@ -2021,9 +2110,9 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) case TCL_PLATFORM_WINDOWS: /* * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if - * this is the first absolute element, or a later relative - * element. Add an extra slash if this is a UNC path. + * trailing slash if needed. Otherwise add the slash if this is + * the first absolute element, or a later relative element. Add + * an extra slash if this is a UNC path. */ if (*name == ':') { @@ -2043,8 +2132,8 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) break; case TCL_PLATFORM_UNIX: /* - * Add a separator if this is the first absolute element, or - * a later relative element. + * Add a separator if this is the first absolute element, or a + * later relative element. */ if ((*pattern != '\0') && (((length > 0) @@ -2058,8 +2147,8 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) #endif /* PROBABLY_OBSOLETE */ /* - * Look for the first matching pair of braces or the first - * directory separator that is not inside a pair of braces. + * Look for the first matching pair of braces or the first directory + * separator that is not inside a pair of braces. */ openBrace = closeBrace = NULL; @@ -2067,26 +2156,37 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) for (p = pattern; *p != '\0'; p++) { if (quoted) { quoted = 0; + } else if (*p == '\\') { quoted = 1; if (strchr(separators, p[1]) != NULL) { - /* Quoted directory separator. */ + /* + * Quoted directory separator. + */ break; } + } else if (strchr(separators, *p) != NULL) { - /* Unquoted directory separator. */ + /* + * Unquoted directory separator. + */ break; + } else if (*p == '{') { openBrace = p; p++; if (SkipToChar(&p, '}')) { - /* Balanced braces. */ + /* + * Balanced braces. + */ + closeBrace = p; break; } Tcl_SetResult(interp, "unmatched open-brace in file name", TCL_STATIC); return TCL_ERROR; + } else if (*p == '}') { Tcl_SetResult(interp, "unmatched close-brace in file name", TCL_STATIC); @@ -2105,9 +2205,9 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_DStringInit(&newName); /* - * For each element within in the outermost pair of braces, - * append the element and the remainder to the fixed portion - * before the first brace and recursively call DoGlob. + * For each element within in the outermost pair of braces, append the + * element and the remainder to the fixed portion before the first + * brace and recursively call DoGlob. */ Tcl_DStringAppend(&newName, pattern, openBrace-pattern); @@ -2132,27 +2232,27 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } /* - * At this point, there are no more brace substitutions to perform on - * this path component. The variable p is pointing at a quoted or - * unquoted directory separator or the end of the string. So we need - * to check for special globbing characters in the current pattern. - * We avoid modifying pattern if p is pointing at the end of the string. + * At this point, there are no more brace substitutions to perform on this + * path component. The variable p is pointing at a quoted or unquoted + * directory separator or the end of the string. So we need to check for + * special globbing characters in the current pattern. We avoid modifying + * pattern if p is pointing at the end of the string. * * If we find any globbing characters, then we must call - * Tcl_FSMatchInDirectory. If we're at the end of the string, then - * that's all we need to do. If we're not at the end of the - * string, then we must recurse, so we do that below. + * Tcl_FSMatchInDirectory. If we're at the end of the string, then that's + * all we need to do. If we're not at the end of the string, then we must + * recurse, so we do that below. * - * Alternatively, if there are no globbing characters then again - * there are two cases. If we're at the end of the string, we just - * need to check for the given path's existence and type. If we're - * not at the end of the string, we recurse. + * Alternatively, if there are no globbing characters then again there are + * two cases. If we're at the end of the string, we just need to check for + * the given path's existence and type. If we're not at the end of the + * string, we recurse. */ if (*p != '\0') { /* - * Note that we are modifying the string in place. This won't work - * if the string is a static. + * Note that we are modifying the string in place. This won't work if + * the string is a static. */ char savedChar = *p; @@ -2165,10 +2265,9 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) if (firstSpecialChar != NULL) { /* - * Look for matching files in the given directory. The - * implementation of this function is filesystem specific. For - * each file that matches, it will add the match onto the - * resultPtr given. + * Look for matching files in the given directory. The implementation + * of this function is filesystem specific. For each file that + * matches, it will add the match onto the resultPtr given. */ static Tcl_GlobTypeData dirOnly = { @@ -2183,7 +2282,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } /* - * We do the recursion ourselves. This makes implementing + * We do the recursion ourselves. This makes implementing * Tcl_FSMatchInDirectory for each filesystem much easier. */ @@ -2215,13 +2314,13 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) /* * This is the code path reached by a command like 'glob foo'. * - * There are no more wildcards in the pattern and no more - * unprocessed characters in the pattern, so now we can construct - * the path, and pass it to Tcl_FSMatchInDirectory with an - * empty pattern to verify the existence of the file and check - * it is of the correct type (if a 'types' flag it given -- if - * no such flag was given, we could just use 'Tcl_FSLStat', but - * for simplicity we keep to a common approach). + * There are no more wildcards in the pattern and no more unprocessed + * characters in the pattern, so now we can construct the path, and + * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify + * the existence of the file and check it is of the correct type (if a + * 'types' flag it given -- if no such flag was given, we could just + * use 'Tcl_FSLStat', but for simplicity we keep to a common + * approach). */ int length; @@ -2246,6 +2345,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) Tcl_DStringAppend(&append, ".", 1); } } + #if defined(__CYGWIN__) && defined(__WIN32__) { extern int cygwin_conv_to_win32_path(CONST char *, char *); @@ -2257,6 +2357,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } #endif /* __CYGWIN__ && __WIN32__ */ break; + case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { @@ -2267,7 +2368,11 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } break; } - /* Common for all platforms */ + + /* + * Common for all platforms. + */ + if (pathPtr == NULL) { joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append), Tcl_DStringLength(&append)); @@ -2277,9 +2382,13 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } else { joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) { - /* The current prefix must end in a separator */ + /* + * The current prefix must end in a separator. + */ + int len; CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); } @@ -2305,16 +2414,17 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } else { joinedPtr = Tcl_DuplicateObj(pathPtr); if (strchr(separators, pattern[0]) == NULL) { - /* - * The current prefix must end in a separator, unless - * this is a volume-relative path. In particular - * globbing in Windows shares, when not using -dir - * or -path, e.g. 'glob [file join //machine/share/subdir *]' - * requires adding a separator here. This behaviour - * is not currently tested for in the test suite. + /* + * The current prefix must end in a separator, unless this is a + * volume-relative path. In particular globbing in Windows + * shares, when not using -dir or -path, e.g. 'glob [file join + * //machine/share/subdir *]' requires adding a separator here. + * This behaviour is not currently tested for in the test suite. */ + int len; CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2336,16 +2446,16 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) * * Tcl_AllocStatBuf -- * - * This procedure allocates a Tcl_StatBuf on the heap. It exists - * so that extensions may be used unchanged on systems where - * largefile support is optional. + * This procedure allocates a Tcl_StatBuf on the heap. It exists so that + * extensions may be used unchanged on systems where largefile support is + * optional. * * Results: - * A pointer to a Tcl_StatBuf which may be deallocated by being - * passed to ckfree(). + * A pointer to a Tcl_StatBuf which may be deallocated by being passed to + * ckfree(). * * Side effects: - * None. + * None. * *--------------------------------------------------------------------------- */ @@ -2354,3 +2464,11 @@ Tcl_StatBuf * Tcl_AllocStatBuf() { return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIO.c b/generic/tclIO.c index 0766e19..e11f489 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -1,4 +1,4 @@ -/* +/* * tclIO.c -- * * This file provides the generic portions (those that are the same on @@ -10,59 +10,47 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.90 2005/06/22 19:47:43 kennykb Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.91 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" #include "tclIO.h" #include - /* - * All static variables used in this file are collected into a single - * instance of the following structure. For multi-threaded implementations, - * there is one instance of this structure for each thread. + * All static variables used in this file are collected into a single instance + * of the following structure. For multi-threaded implementations, there is + * one instance of this structure for each thread. * - * Notice that different structures with the same name appear in other - * files. The structure defined below is used in this file only. + * Notice that different structures with the same name appear in other files. + * The structure defined below is used in this file only. */ typedef struct ThreadSpecificData { - /* - * This variable holds the list of nested ChannelHandlerEventProc - * invocations. - */ NextChannelHandler *nestedHandlerPtr; - - /* - * List of all channels currently open, indexed by ChannelState, - * as only one ChannelState exists per set of stacked channels. - */ - ChannelState *firstCSPtr; - + /* This variable holds the list of + * nested ChannelHandlerEventProc + * invocations. */ + ChannelState *firstCSPtr; /* List of all channels currently + * open, indexed by ChannelState, as + * only one ChannelState exists per + * set of stacked channels. */ #ifdef oldcode - /* - * Has a channel exit handler been created yet? - */ - int channelExitHandlerCreated; - - /* - * Has the channel event source been created and registered with the - * notifier? - */ - int channelEventSourceCreated; + int channelExitHandlerCreated; /* Has a channel exit handler been + * created yet? */ + int channelEventSourceCreated; /* Has the channel event source been + * created and registered with the + * notifier? */ #endif - - /* - * Static variables to hold channels for stdin, stdout and stderr. - */ - Tcl_Channel stdinChannel; + Tcl_Channel stdinChannel; /* Static variable for the stdin + * channel. */ int stdinInitialized; - Tcl_Channel stdoutChannel; + Tcl_Channel stdoutChannel; /* Static variable for the stdout + * channel. */ int stdoutInitialized; - Tcl_Channel stderrChannel; + Tcl_Channel stderrChannel; /* Static variable for the stderr + * channel. */ int stderrInitialized; - } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; @@ -155,7 +143,7 @@ static int WriteChars _ANSI_ARGS_((Channel *chanPtr, * TclInitIOSubsystem -- * * Initialize all resources used by this subsystem on a per-process - * basis. + * basis. * * Results: * None. @@ -170,20 +158,21 @@ void TclInitIOSubsystem() { /* - * By fetching thread local storage we take care of - * allocating it for each thread. + * By fetching thread local storage we take care of allocating it for each + * thread. */ + (void) TCL_TSD_INIT(&dataKey); -} +} /* *------------------------------------------------------------------------- * * TclFinalizeIOSubsystem -- * - * Releases all resources used by this subsystem on a per-process - * basis. Closes all extant channels that have not already been - * closed because they were not owned by any interp. + * Releases all resources used by this subsystem on a per-process basis. + * Closes all extant channels that have not already been closed because + * they were not owned by any interp. * * Results: * None. @@ -209,8 +198,8 @@ TclFinalizeIOSubsystem() nextCSPtr = statePtr->nextCSPtr; /* - * Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. + * Set the channel back into blocking mode to ensure that we wait for + * all data to flush out. */ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, @@ -219,27 +208,24 @@ TclFinalizeIOSubsystem() if ((chanPtr == (Channel *) tsdPtr->stdinChannel) || (chanPtr == (Channel *) tsdPtr->stdoutChannel) || (chanPtr == (Channel *) tsdPtr->stderrChannel)) { - /* - * Decrement the refcount which was earlier artificially bumped - * up to keep the channel from being closed. + * Decrement the refcount which was earlier artificially bumped up + * to keep the channel from being closed. */ statePtr->refCount--; } if (statePtr->refCount <= 0) { - /* * Close it only if the refcount indicates that the channel is not - * referenced from any interpreter. If it is, that interpreter will - * close the channel when it gets destroyed. + * referenced from any interpreter. If it is, that interpreter + * will close the channel when it gets destroyed. */ (void) Tcl_Close((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else { - /* * The refcount is greater than zero, so flush the channel. */ @@ -247,8 +233,8 @@ TclFinalizeIOSubsystem() Tcl_Flush((Tcl_Channel) chanPtr); /* - * Call the device driver to actually close the underlying - * device for this channel. + * Call the device driver to actually close the underlying device + * for this channel. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { @@ -278,8 +264,8 @@ TclFinalizeIOSubsystem() * * Tcl_SetStdChannel -- * - * This function is used to change the channels that are used - * for stdin/stdout/stderr in new interpreters. + * This function is used to change the channels that are used for + * stdin/stdout/stderr in new interpreters. * * Results: * None @@ -297,18 +283,18 @@ Tcl_SetStdChannel(channel, type) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { - case TCL_STDIN: - tsdPtr->stdinInitialized = 1; - tsdPtr->stdinChannel = channel; - break; - case TCL_STDOUT: - tsdPtr->stdoutInitialized = 1; - tsdPtr->stdoutChannel = channel; - break; - case TCL_STDERR: - tsdPtr->stderrInitialized = 1; - tsdPtr->stderrChannel = channel; - break; + case TCL_STDIN: + tsdPtr->stdinInitialized = 1; + tsdPtr->stdinChannel = channel; + break; + case TCL_STDOUT: + tsdPtr->stdoutInitialized = 1; + tsdPtr->stdoutChannel = channel; + break; + case TCL_STDERR: + tsdPtr->stderrInitialized = 1; + tsdPtr->stderrChannel = channel; + break; } } @@ -323,8 +309,7 @@ Tcl_SetStdChannel(channel, type) * Returns the specified standard channel, or NULL. * * Side effects: - * May cause the creation of a standard channel and the underlying - * file. + * May cause the creation of a standard channel and the underlying file. * *---------------------------------------------------------------------- */ @@ -337,54 +322,54 @@ Tcl_GetStdChannel(type) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); /* - * If the channels were not created yet, create them now and - * store them in the static variables. + * If the channels were not created yet, create them now and store them in + * the static variables. */ switch (type) { - case TCL_STDIN: - if (!tsdPtr->stdinInitialized) { - tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); - tsdPtr->stdinInitialized = 1; + case TCL_STDIN: + if (!tsdPtr->stdinInitialized) { + tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); + tsdPtr->stdinInitialized = 1; - /* - * Artificially bump the refcount to ensure that the channel - * is only closed on exit. - * - * NOTE: Must only do this if stdinChannel is not NULL. It - * can be NULL in situations where Tcl is unable to connect - * to the standard input. - */ + /* + * Artificially bump the refcount to ensure that the channel is + * only closed on exit. + * + * NOTE: Must only do this if stdinChannel is not NULL. It can be + * NULL in situations where Tcl is unable to connect to the + * standard input. + */ - if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stdinChannel); - } + if (tsdPtr->stdinChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stdinChannel); } - channel = tsdPtr->stdinChannel; - break; - case TCL_STDOUT: - if (!tsdPtr->stdoutInitialized) { - tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); - tsdPtr->stdoutInitialized = 1; - if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stdoutChannel); - } + } + channel = tsdPtr->stdinChannel; + break; + case TCL_STDOUT: + if (!tsdPtr->stdoutInitialized) { + tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); + tsdPtr->stdoutInitialized = 1; + if (tsdPtr->stdoutChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stdoutChannel); } - channel = tsdPtr->stdoutChannel; - break; - case TCL_STDERR: - if (!tsdPtr->stderrInitialized) { - tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); - tsdPtr->stderrInitialized = 1; - if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { - (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, - tsdPtr->stderrChannel); - } + } + channel = tsdPtr->stdoutChannel; + break; + case TCL_STDERR: + if (!tsdPtr->stderrInitialized) { + tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); + tsdPtr->stderrInitialized = 1; + if (tsdPtr->stderrChannel != (Tcl_Channel) NULL) { + (void) Tcl_RegisterChannel((Tcl_Interp *) NULL, + tsdPtr->stderrChannel); } - channel = tsdPtr->stderrChannel; - break; + } + channel = tsdPtr->stderrChannel; + break; } return channel; } @@ -401,20 +386,20 @@ Tcl_GetStdChannel(type) * None. * * Side effects: - * Causes the callback to be called in the future when the channel - * will be closed. + * Causes the callback to be called in the future when the channel will + * be closed. * *---------------------------------------------------------------------- */ void Tcl_CreateCloseHandler(chan, proc, clientData) - Tcl_Channel chan; /* The channel for which to create the - * close callback. */ + Tcl_Channel chan; /* The channel for which to create the close + * callback. */ Tcl_CloseProc *proc; /* The callback routine to call when the * channel will be closed. */ - ClientData clientData; /* Arbitrary data to pass to the - * close callback. */ + ClientData clientData; /* Arbitrary data to pass to the close + * callback. */ { ChannelState *statePtr; CloseCallback *cbPtr; @@ -434,28 +419,27 @@ Tcl_CreateCloseHandler(chan, proc, clientData) * * Tcl_DeleteCloseHandler -- * - * Removes a callback that would have been called on closing - * the channel. If there is no matching callback then this - * function has no effect. + * Removes a callback that would have been called on closing the channel. + * If there is no matching callback then this function has no effect. * * Results: * None. * * Side effects: - * The callback will not be called in the future when the channel - * is eventually closed. + * The callback will not be called in the future when the channel is + * eventually closed. * *---------------------------------------------------------------------- */ void Tcl_DeleteCloseHandler(chan, proc, clientData) - Tcl_Channel chan; /* The channel for which to cancel the - * close callback. */ + Tcl_Channel chan; /* The channel for which to cancel the close + * callback. */ Tcl_CloseProc *proc; /* The procedure for the callback to * remove. */ - ClientData clientData; /* The callback data for the callback - * to remove. */ + ClientData clientData; /* The callback data for the callback to + * remove. */ { ChannelState *statePtr; CloseCallback *cbPtr, *cbPrevPtr; @@ -481,17 +465,16 @@ Tcl_DeleteCloseHandler(chan, proc, clientData) * * GetChannelTable -- * - * Gets and potentially initializes the channel table for an - * interpreter. If it is initializing the table it also inserts - * channels for stdin, stdout and stderr if the interpreter is - * trusted. + * Gets and potentially initializes the channel table for an interpreter. + * If it is initializing the table it also inserts channels for stdin, + * stdout and stderr if the interpreter is trusted. * * Results: * A pointer to the hash table created, for use by the caller. * * Side effects: - * Initializes the channel table for an interpreter. May create - * channels for stdin, stdout and stderr. + * Initializes the channel table for an interpreter. May create channels + * for stdin, stdout and stderr. * *---------------------------------------------------------------------- */ @@ -513,9 +496,8 @@ GetChannelTable(interp) (ClientData) hTblPtr); /* - * If the interpreter is trusted (not "safe"), insert channels - * for stdin, stdout and stderr (possibly creating them in the - * process). + * If the interpreter is trusted (not "safe"), insert channels for + * stdin, stdout and stderr (possibly creating them in the process). */ if (Tcl_IsSafe(interp) == 0) { @@ -542,9 +524,8 @@ GetChannelTable(interp) * DeleteChannelTable -- * * Deletes the channel table for an interpreter, closing any open - * channels whose refcount reaches zero. This procedure is invoked - * when an interpreter is deleted, via the AssocData cleanup - * mechanism. + * channels whose refcount reaches zero. This procedure is invoked when + * an interpreter is deleted, via the AssocData cleanup mechanism. * * Results: * None. @@ -568,7 +549,7 @@ DeleteChannelTable(clientData, interp) Channel *chanPtr; /* Channel being deleted. */ ChannelState *statePtr; /* State of Channel being deleted. */ EventScriptRecord *sPtr, *prevPtr, *nextPtr; - /* Variables to loop over all channel events + /* Variables to loop over all channel events * registered, to delete the ones that refer * to the interpreter being deleted. */ @@ -613,9 +594,9 @@ DeleteChannelTable(clientData, interp) /* * Cannot call Tcl_UnregisterChannel because that procedure calls - * Tcl_GetAssocData to get the channel table, which might already - * be inaccessible from the interpreter structure. Instead, we - * emulate the behavior of Tcl_UnregisterChannel directly here. + * Tcl_GetAssocData to get the channel table, which might already be + * inaccessible from the interpreter structure. Instead, we emulate + * the behavior of Tcl_UnregisterChannel directly here. */ Tcl_DeleteHashEntry(hPtr); @@ -636,11 +617,11 @@ DeleteChannelTable(clientData, interp) * CheckForStdChannelsBeingClosed -- * * Perform special handling for standard channels being closed. When - * given a standard channel, if the refcount is now 1, it means that - * the last reference to the standard channel is being explicitly - * closed. Now bump the refcount artificially down to 0, to ensure the - * normal handling of channels being closed will occur. Also reset the - * static pointer to the channel to NULL, to avoid dangling references. + * given a standard channel, if the refcount is now 1, it means that the + * last reference to the standard channel is being explicitly closed. Now + * bump the refcount artificially down to 0, to ensure the normal + * handling of channels being closed will occur. Also reset the static + * pointer to the channel to NULL, to avoid dangling references. * * Results: * None. @@ -700,13 +681,13 @@ CheckForStdChannelsBeingClosed(chan) *---------------------------------------------------------------------- */ -int +int Tcl_IsStandardChannel(chan) Tcl_Channel chan; /* Channel to check. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if ((chan == tsdPtr->stdinChannel) + if ((chan == tsdPtr->stdinChannel) || (chan == tsdPtr->stdoutChannel) || (chan == tsdPtr->stderrChannel)) { return 1; @@ -721,8 +702,8 @@ Tcl_IsStandardChannel(chan) * Tcl_RegisterChannel -- * * Adds an already-open channel to the channel table of an interpreter. - * If the interpreter passed as argument is NULL, it only increments - * the channel refCount. + * If the interpreter passed as argument is NULL, it only increments the + * channel refCount. * * Results: * None. @@ -781,17 +762,17 @@ Tcl_RegisterChannel(interp, chan) * If the interpreter given as argument is NULL, it only decrements the * reference count. (This all happens in the Tcl_DetachChannel helper * function). - * - * Finally, if the reference count of the channel drops to zero, - * it is deleted. + * + * Finally, if the reference count of the channel drops to zero, it is + * deleted. * * Results: * A standard Tcl result. * * Side effects: - * Calls Tcl_DetachChannel which deletes the hash entry for a channel + * Calls Tcl_DetachChannel which deletes the hash entry for a channel * associated with an interpreter. - * + * * May delete the channel, which can have a variety of consequences, * especially if we are forced to close the channel. * @@ -838,8 +819,8 @@ Tcl_UnregisterChannel(interp, chan) if (statePtr->refCount <= 0) { /* - * Ensure that if there is another buffer, it gets flushed - * whether or not we are doing a background flush. + * Ensure that if there is another buffer, it gets flushed whether or + * not we are doing a background flush. */ if ((statePtr->curOutPtr != NULL) && @@ -849,7 +830,10 @@ Tcl_UnregisterChannel(interp, chan) } Tcl_Preserve((ClientData)statePtr); if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { - /* We don't want to re-enter Tcl_Close */ + /* + * We don't want to re-enter Tcl_Close(). + */ + if (!(statePtr->flags & CHANNEL_CLOSED)) { if (Tcl_Close(interp, chan) != TCL_OK) { statePtr->flags |= CHANNEL_CLOSED; @@ -871,32 +855,29 @@ Tcl_UnregisterChannel(interp, chan) * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the - * reference count. Even if the ref count drops to zero, the - * channel is NOT closed or cleaned up. This allows a channel to - * be detached from an interpreter and left in the same state it - * was in when it was originally returned by 'Tcl_OpenFileChannel', - * for example. - * - * This function cannot be used on the standard channels, and - * will return TCL_ERROR if that is attempted. - * - * This function should only be necessary for special purposes - * in which you need to generate a pristine channel from one - * that has already been used. All ordinary purposes will almost - * always want to use Tcl_UnregisterChannel instead. - * - * Provided the channel is not attached to any other interpreter, - * it can then be closed with Tcl_Close, rather than with - * Tcl_UnregisterChannel. + * reference count. Even if the ref count drops to zero, the channel is + * NOT closed or cleaned up. This allows a channel to be detached from + * an interpreter and left in the same state it was in when it was + * originally returned by 'Tcl_OpenFileChannel', for example. + * + * This function cannot be used on the standard channels, and will return + * TCL_ERROR if that is attempted. + * + * This function should only be necessary for special purposes in which + * you need to generate a pristine channel from one that has already been + * used. All ordinary purposes will almost always want to use + * Tcl_UnregisterChannel instead. + * + * Provided the channel is not attached to any other interpreter, it can + * then be closed with Tcl_Close, rather than with Tcl_UnregisterChannel. * * Results: * A standard Tcl result. If the channel is not currently registered - * with the given interpreter, TCL_ERROR is returned, otherwise - * TCL_OK. However no error messages are left in the interp's result. + * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. + * However no error messages are left in the interp's result. * * Side effects: - * Deletes the hash entry for a channel associated with an - * interpreter. + * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ @@ -920,20 +901,18 @@ Tcl_DetachChannel(interp, chan) * * Deletes the hash entry for a channel associated with an interpreter. * If the interpreter given as argument is NULL, it only decrements the - * reference count. Even if the ref count drops to zero, the - * channel is NOT closed or cleaned up. This allows a channel to - * be detached from an interpreter and left in the same state it - * was in when it was originally returned by 'Tcl_OpenFileChannel', - * for example. + * reference count. Even if the ref count drops to zero, the channel is + * NOT closed or cleaned up. This allows a channel to be detached from + * an interpreter and left in the same state it was in when it was + * originally returned by 'Tcl_OpenFileChannel', for example. * * Results: * A standard Tcl result. If the channel is not currently registered - * with the given interpreter, TCL_ERROR is returned, otherwise - * TCL_OK. However no error messages are left in the interp's result. + * with the given interpreter, TCL_ERROR is returned, otherwise TCL_OK. + * However no error messages are left in the interp's result. * * Side effects: - * Deletes the hash entry for a channel associated with an - * interpreter. + * Deletes the hash entry for a channel associated with an interpreter. * *---------------------------------------------------------------------- */ @@ -972,10 +951,10 @@ DetachChannel(interp, chan) Tcl_DeleteHashEntry(hPtr); /* - * Remove channel handlers that refer to this interpreter, so that they - * will not be present if the actual close is delayed and more events - * happen on the channel. This may occur if the channel is shared - * between several interpreters, or if the channel has async + * Remove channel handlers that refer to this interpreter, so that + * they will not be present if the actual close is delayed and more + * events happen on the channel. This may occur if the channel is + * shared between several interpreters, or if the channel has async * flushing active. */ @@ -997,9 +976,9 @@ DetachChannel(interp, chan) * channel-type-specific functions. * * Results: - * A Tcl_Channel or NULL on failure. If failed, interp's result - * object contains an error message. *modePtr is filled with the - * modes in which the channel was opened. + * A Tcl_Channel or NULL on failure. If failed, interp's result object + * contains an error message. *modePtr is filled with the modes in which + * the channel was opened. * * Side effects: * None. @@ -1009,8 +988,8 @@ DetachChannel(interp, chan) Tcl_Channel Tcl_GetChannel(interp, chanName, modePtr) - Tcl_Interp *interp; /* Interpreter in which to find or create - * the channel. */ + Tcl_Interp *interp; /* Interpreter in which to find or create the + * channel. */ CONST char *chanName; /* The name of the channel. */ int *modePtr; /* Where to store the mode in which the * channel was opened? Will contain an ORed @@ -1023,11 +1002,11 @@ Tcl_GetChannel(interp, chanName, modePtr) CONST char *name; /* Translated name. */ /* - * Substitute "stdin", etc. Note that even though we immediately - * find the channel using Tcl_GetStdChannel, we still need to look - * it up in the specified interpreter to ensure that it is present - * in the channel table. Otherwise, safe interpreters would always - * have access to the standard channels. + * Substitute "stdin", etc. Note that even though we immediately find the + * channel using Tcl_GetStdChannel, we still need to look it up in the + * specified interpreter to ensure that it is present in the channel + * table. Otherwise, safe interpreters would always have access to the + * standard channels. */ name = chanName; @@ -1054,10 +1033,9 @@ Tcl_GetChannel(interp, chanName, modePtr) } /* - * Always return bottom-most channel in the stack. This one lives - * the longest - other channels may go away unnoticed. - * The other APIs compensate where necessary to retrieve the - * topmost channel again. + * Always return bottom-most channel in the stack. This one lives the + * longest - other channels may go away unnoticed. The other APIs + * compensate where necessary to retrieve the topmost channel again. */ chanPtr = (Channel *) Tcl_GetHashValue(hPtr); @@ -1074,15 +1052,13 @@ Tcl_GetChannel(interp, chanName, modePtr) * * Tcl_CreateChannel -- * - * Creates a new entry in the hash table for a Tcl_Channel - * record. + * Creates a new entry in the hash table for a Tcl_Channel record. * * Results: * Returns the new Tcl_Channel. * * Side effects: - * Creates a new Tcl_Channel instance and inserts it into the - * hash table. + * Creates a new Tcl_Channel instance and inserts it into the hash table. * *---------------------------------------------------------------------- */ @@ -1092,12 +1068,12 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) Tcl_ChannelType *typePtr; /* The channel type record. */ CONST char *chanName; /* Name of channel to record. */ ClientData instanceData; /* Instance specific data. */ - int mask; /* TCL_READABLE & TCL_WRITABLE to indicate - * if the channel is readable, writable. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if + * the channel is readable, writable. */ { Channel *chanPtr; /* The channel structure newly created. */ - ChannelState *statePtr; /* The stack-level independent state info - * for the channel. */ + ChannelState *statePtr; /* The stack-level independent state info for + * the channel. */ CONST char *name; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1106,16 +1082,16 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * 8.3.2+, we have to make sure that our assumption that the structure * remains a binary compatible size is true. * - * If this assertion fails on some system, then it can be removed - * only if the user recompiles code with older channel drivers in - * the new system as well. + * If this assertion fails on some system, then it can be removed only if + * the user recompiles code with older channel drivers in the new system + * as well. */ assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc*)); /* - * JH: We could subsequently memset these to 0 to avoid the - * numerous assignments to 0/NULL below. + * JH: We could subsequently memset these to 0 to avoid the numerous + * assignments to 0/NULL below. */ chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); @@ -1143,18 +1119,17 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) /* * Set the channel to system default encoding. * - * Note the strange bit of protection taking place here. - * If the system encoding name is reported back as "binary", - * something weird is happening. Tcl provides no "binary" - * encoding, so someone else has provided one. We ignore it - * so as not to interfere with the "magic" interpretation - * that Tcl_Channels give to the "-encoding binary" option. + * Note the strange bit of protection taking place here. If the system + * encoding name is reported back as "binary", something weird is + * happening. Tcl provides no "binary" encoding, so someone else has + * provided one. We ignore it so as not to interfere with the "magic" + * interpretation that Tcl_Channels give to the "-encoding binary" option. */ statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); if (strcmp(name, "binary") != 0) { - statePtr->encoding = Tcl_GetEncoding(NULL, name); + statePtr->encoding = Tcl_GetEncoding(NULL, name); } statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; @@ -1162,11 +1137,11 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) statePtr->outputEncodingFlags = TCL_ENCODING_START; /* - * Set the channel up initially in AUTO input translation mode to - * accept "\n", "\r" and "\r\n". Output translation mode is set to - * a platform specific default value. The eofChar is set to 0 for both - * input and output, so that Tcl does not look for an in-file EOF - * indicator (e.g. ^Z) and does not append an EOF indicator to files. + * Set the channel up initially in AUTO input translation mode to accept + * "\n", "\r" and "\r\n". Output translation mode is set to a platform + * specific default value. The eofChar is set to 0 for both input and + * output, so that Tcl does not look for an in-file EOF indicator + * (e.g. ^Z) and does not append an EOF indicator to files. */ statePtr->inputTranslation = TCL_TRANSLATE_AUTO; @@ -1197,7 +1172,7 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) } /* - * As we are creating the channel, it is obviously the top for now + * As we are creating the channel, it is obviously the top for now. */ statePtr->topChanPtr = chanPtr; @@ -1209,31 +1184,30 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) /* * Link the channel into the list of all channels; create an on-exit - * handler if there is not one already, to close off all the channels - * in the list on exit. + * handler if there is not one already, to close off all the channels in + * the list on exit. * * JH: Could call Tcl_SpliceChannel, but need to avoid NULL check. * * TIP #218. * AK: Just initialize the field to NULL before invoking Tcl_SpliceChannel - * We need Tcl_SpliceChannel, for the threadAction calls. - * There is no real reason to duplicate all of this. + * We need Tcl_SpliceChannel, for the threadAction calls. There is no + * real reason to duplicate all of this. * NOTE: All drivers using thread actions now have to perform their TSD - * manipulation only in their thread action proc. Doing it when - * creating their instance structures will collide with the thread - * action activity and lead to damaged lists. + * manipulation only in their thread action proc. Doing it when + * creating their instance structures will collide with the thread + * action activity and lead to damaged lists. */ statePtr->nextCSPtr = (ChannelState *) NULL; Tcl_SpliceChannel ((Tcl_Channel) chanPtr); /* - * Install this channel in the first empty standard channel slot, if - * the channel was previously closed explicitly. + * Install this channel in the first empty standard channel slot, if the + * channel was previously closed explicitly. */ - if ((tsdPtr->stdinChannel == NULL) && - (tsdPtr->stdinInitialized == 1)) { + if ((tsdPtr->stdinChannel == NULL) && (tsdPtr->stdinInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDIN); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); } else if ((tsdPtr->stdoutChannel == NULL) && @@ -1244,7 +1218,7 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) (tsdPtr->stderrInitialized == 1)) { Tcl_SetStdChannel((Tcl_Channel) chanPtr, TCL_STDERR); Tcl_RegisterChannel((Tcl_Interp *) NULL, (Tcl_Channel) chanPtr); - } + } return (Tcl_Channel) chanPtr; } @@ -1253,26 +1227,24 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) * * Tcl_StackChannel -- * - * Replaces an entry in the hash table for a Tcl_Channel - * record. The replacement is a new channel with same name, - * it supercedes the replaced channel. Input and output of - * the superceded channel is now going through the newly - * created channel and allows the arbitrary filtering/manipulation - * of the dataflow. + * Replaces an entry in the hash table for a Tcl_Channel record. The + * replacement is a new channel with same name, it supercedes the + * replaced channel. Input and output of the superceded channel is now + * going through the newly created channel and allows the arbitrary + * filtering/manipulation of the dataflow. * - * Andreas Kupries , 12/13/1998 - * "Trf-Patch for filtering channels" + * Andreas Kupries , 12/13/1998 "Trf-Patch for + * filtering channels" * * Results: - * Returns the new Tcl_Channel, which actually contains the - * saved information about prevChan. + * Returns the new Tcl_Channel, which actually contains the saved + * information about prevChan. * * Side effects: - * A new channel structure is allocated and linked below - * the existing channel. The channel operations and client - * data of the existing channel are copied down to the newly - * created channel, and the current channel has its operations - * replaced by the new typePtr. + * A new channel structure is allocated and linked below the existing + * channel. The channel operations and client data of the existing channel + * are copied down to the newly created channel, and the current channel + * has its operations replaced by the new typePtr. * *---------------------------------------------------------------------- */ @@ -1284,8 +1256,8 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) * channel. */ ClientData instanceData; /* Instance specific data for the new * channel. */ - int mask; /* TCL_READABLE & TCL_WRITABLE to indicate - * if the channel is readable, writable. */ + int mask; /* TCL_READABLE & TCL_WRITABLE to indicate if + * the channel is readable, writable. */ Tcl_Channel prevChan; /* The channel structure to replace */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1293,8 +1265,8 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) ChannelState *statePtr; /* - * Find the given channel in the list of all channels. - * If we don't find it, then it was never registered correctly. + * Find the given channel in the list of all channels. If we don't find + * it, then it was never registered correctly. * * This operation should occur at the top of a channel stack. */ @@ -1313,15 +1285,15 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) } /* - * Here we check if the given "mask" matches the "flags" - * of the already existing channel. + * Here we check if the given "mask" matches the "flags" of the already + * existing channel. * * | - | R | W | RW | * --+---+---+---+----+ <=> 0 != (chan->mask & prevChan->mask) * - | | | | | - * R | | + | | + | The superceding channel is allowed to - * W | | | + | + | restrict the capabilities of the - * RW| | + | + | + | superceded one ! + * R | | + | | + | The superceding channel is allowed to restrict + * W | | | + | + | the capabilities of the superceded one! + * RW| | + | + | + | * --+---+---+---+----+ */ @@ -1333,10 +1305,10 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) } /* - * Flush the buffers. This ensures that any data still in them - * at this time is not handled by the new transformation. Restrict - * this to writable channels. Take care to hide a possible bg-copy - * in progress from Tcl_Flush and the CheckForChannelErrors inside. + * Flush the buffers. This ensures that any data still in them at this + * time is not handled by the new transformation. Restrict this to + * writable channels. Take care to hide a possible bg-copy in progress + * from Tcl_Flush and the CheckForChannelErrors inside. */ if ((mask & TCL_WRITABLE) != 0) { @@ -1355,26 +1327,25 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) statePtr->csPtr = csPtr; } /* - * Discard any input in the buffers. They are not yet read by the - * user of the channel, so they have to go through the new - * transformation before reading. As the buffers contain the - * untransformed form their contents are not only useless but actually - * distorts our view of the system. + * Discard any input in the buffers. They are not yet read by the user of + * the channel, so they have to go through the new transformation before + * reading. As the buffers contain the untransformed form their contents + * are not only useless but actually distorts our view of the system. * - * To preserve the information without having to read them again and - * to avoid problems with the location in the channel (seeking might - * be impossible) we move the buffers from the common state structure - * into the channel itself. We use the buffers in the channel below - * the new transformation to hold the data. In the future this allows - * us to write transformations which pre-read data and push the unused - * part back when they are going away. + * To preserve the information without having to read them again and to + * avoid problems with the location in the channel (seeking might be + * impossible) we move the buffers from the common state structure into + * the channel itself. We use the buffers in the channel below the new + * transformation to hold the data. In the future this allows us to write + * transformations which pre-read data and push the unused part back when + * they are going away. */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != (ChannelBuffer *) NULL)) { /* - * Remark: It is possible that the channel buffers contain - * data from some earlier push-backs. + * Remark: It is possible that the channel buffers contain data from + * some earlier push-backs. */ statePtr->inQueueTail->nextPtr = prevChanPtr->inQueueHead; @@ -1391,8 +1362,8 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) chanPtr = (Channel *) ckalloc((unsigned) sizeof(Channel)); /* - * Save some of the current state into the new structure, - * reinitialize the parts which will stay with the transformation. + * Save some of the current state into the new structure, reinitialize the + * parts which will stay with the transformation. * * Remarks: */ @@ -1421,15 +1392,15 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) * * Tcl_UnstackChannel -- * - * Unstacks an entry in the hash table for a Tcl_Channel - * record. This is the reverse to 'Tcl_StackChannel'. + * Unstacks an entry in the hash table for a Tcl_Channel record. This is + * the reverse to 'Tcl_StackChannel'. * * Results: * A standard Tcl result. * * Side effects: - * If TCL_ERROR is returned, the posix error code will be set - * with Tcl_SetErrno. + * If TCL_ERROR is returned, the posix error code will be set with + * Tcl_SetErrno. * *---------------------------------------------------------------------- */ @@ -1460,10 +1431,10 @@ Tcl_UnstackChannel(interp, chan) Channel *downChanPtr = chanPtr->downChanPtr; /* - * Flush the buffers. This ensures that any data still in them - * at this time _is_ handled by the transformation we are unstacking - * right now. Restrict this to writable channels. Take care to hide - * a possible bg-copy in progress from Tcl_Flush and the + * Flush the buffers. This ensures that any data still in them at this + * time _is_ handled by the transformation we are unstacking right + * now. Restrict this to writable channels. Take care to hide a + * possible bg-copy in progress from Tcl_Flush and the * CheckForChannelErrors inside. */ @@ -1485,13 +1456,13 @@ Tcl_UnstackChannel(interp, chan) } /* - * Anything in the input queue and the push-back buffers of - * the transformation going away is transformed data, but not - * yet read. As unstacking means that the caller does not want - * to see transformed data any more we have to discard these - * bytes. To avoid writing an analogue to 'DiscardInputQueued' - * we move the information in the push back buffers to the - * input queue and then call 'DiscardInputQueued' on that. + * Anything in the input queue and the push-back buffers of the + * transformation going away is transformed data, but not yet read. As + * unstacking means that the caller does not want to see transformed + * data any more we have to discard these bytes. To avoid writing an + * analogue to 'DiscardInputQueued' we move the information in the + * push back buffers to the input queue and then call + * 'DiscardInputQueued' on that. */ if (((statePtr->flags & TCL_READABLE) != 0) && @@ -1550,8 +1521,8 @@ Tcl_UnstackChannel(interp, chan) } } else { /* - * This channel does not cover another one. - * Simply do a close, if necessary. + * This channel does not cover another one. Simply do a close, if + * necessary. */ if (statePtr->refCount <= 0) { @@ -1572,9 +1543,9 @@ Tcl_UnstackChannel(interp, chan) * Determines whether the specified channel is stacked upon another. * * Results: - * NULL if the channel is not stacked upon another one, or a reference - * to the channel it is stacked upon. This reference can be used in - * queries, but modification is not allowed. + * NULL if the channel is not stacked upon another one, or a reference to + * the channel it is stacked upon. This reference can be used in queries, + * but modification is not allowed. * * Side effects: * None. @@ -1599,9 +1570,9 @@ Tcl_GetStackedChannel(chan) * Returns the top channel of a channel stack. * * Results: - * NULL if the channel is not stacked upon another one, or a reference - * to the channel it is stacked upon. This reference can be used in - * queries, but modification is not allowed. + * NULL if the channel is not stacked upon another one, or a reference to + * the channel it is stacked upon. This reference can be used in queries, + * but modification is not allowed. * * Side effects: * None. @@ -1648,8 +1619,7 @@ Tcl_GetChannelInstanceData(chan) * * Tcl_GetChannelThread -- * - * Given a channel structure, returns the thread managing it. - * TIP #10 + * Given a channel structure, returns the thread managing it. TIP #10 * * Results: * Returns the id of the thread managing the channel. @@ -1662,7 +1632,8 @@ Tcl_GetChannelInstanceData(chan) Tcl_ThreadId Tcl_GetChannelThread(chan) - Tcl_Channel chan; /* The channel to return managing thread for. */ + Tcl_Channel chan; /* The channel to return managing thread + * for. */ { Channel *chanPtr = (Channel *) chan; /* The actual channel. */ @@ -1689,7 +1660,8 @@ Tcl_ChannelType * Tcl_GetChannelType(chan) Tcl_Channel chan; /* The channel to return type for. */ { - Channel *chanPtr = (Channel *) chan; /* The actual channel. */ + Channel *chanPtr = (Channel *) chan; + /* The actual channel. */ return chanPtr->typePtr; } @@ -1699,8 +1671,8 @@ Tcl_GetChannelType(chan) * * Tcl_GetChannelMode -- * - * Computes a mask indicating whether the channel is open for - * reading and writing. + * Computes a mask indicating whether the channel is open for reading and + * writing. * * Results: * An OR-ed combination of TCL_READABLE and TCL_WRITABLE. @@ -1713,11 +1685,11 @@ Tcl_GetChannelType(chan) int Tcl_GetChannelMode(chan) - Tcl_Channel chan; /* The channel for which the mode is - * being computed. */ + Tcl_Channel chan; /* The channel for which the mode is being + * computed. */ { ChannelState *statePtr = ((Channel *) chan)->state; - /* State of actual channel. */ + /* State of actual channel. */ return (statePtr->flags & (TCL_READABLE | TCL_WRITABLE)); } @@ -1730,9 +1702,8 @@ Tcl_GetChannelMode(chan) * Returns the string identifying the channel name. * * Results: - * The string containing the channel name. This memory is - * owned by the generic layer and should not be modified by - * the caller. + * The string containing the channel name. This memory is owned by the + * generic layer and should not be modified by the caller. * * Side effects: * None. @@ -1791,16 +1762,15 @@ Tcl_GetChannelHandle(chan, direction, handlePtr) * * AllocChannelBuffer -- * - * A channel buffer has BUFFER_PADDING bytes extra at beginning to - * hold any bytes of a native-encoding character that got split by - * the end of the previous buffer and need to be moved to the - * beginning of the next buffer to make a contiguous string so it - * can be converted to UTF-8. + * A channel buffer has BUFFER_PADDING bytes extra at beginning to hold + * any bytes of a native-encoding character that got split by the end of + * the previous buffer and need to be moved to the beginning of the next + * buffer to make a contiguous string so it can be converted to UTF-8. * - * A channel buffer has BUFFER_PADDING bytes extra at the end to - * hold any bytes of a native-encoding character (generated from a - * UTF-8 character) that overflow past the end of the buffer and - * need to be moved to the next buffer. + * A channel buffer has BUFFER_PADDING bytes extra at the end to hold any + * bytes of a native-encoding character (generated from a UTF-8 + * character) that overflow past the end of the buffer and need to be + * moved to the next buffer. * * Results: * A newly allocated channel buffer. @@ -1832,11 +1802,10 @@ AllocChannelBuffer(length) * * RecycleBuffer -- * - * Helper function to recycle input and output buffers. Ensures - * that two input buffers are saved (one in the input queue and - * another in the saveInBufPtr field) and that curOutPtr is set - * to a buffer. Only if these conditions are met is the buffer - * freed to the OS. + * Helper function to recycle input and output buffers. Ensures that two + * input buffers are saved (one in the input queue and another in the + * saveInBufPtr field) and that curOutPtr is set to a buffer. Only if + * these conditions are met is the buffer freed to the OS. * * Results: * None. @@ -1851,8 +1820,8 @@ static void RecycleBuffer(statePtr, bufPtr, mustDiscard) ChannelState *statePtr; /* ChannelState in which to recycle buffers. */ ChannelBuffer *bufPtr; /* The buffer to recycle. */ - int mustDiscard; /* If nonzero, free the buffer to the - * OS, always. */ + int mustDiscard; /* If nonzero, free the buffer to the OS, + * always. */ { /* * Do we have to free the buffer to the OS? @@ -1864,9 +1833,9 @@ RecycleBuffer(statePtr, bufPtr, mustDiscard) } /* - * Only save buffers which are at least as big as the requested - * buffersize for the channel. This is to honor dynamic changes - * of the buffersize made by the user. + * Only save buffers which are at least as big as the requested buffersize + * for the channel. This is to honor dynamic changes of the buffersize + * made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) { @@ -1882,11 +1851,11 @@ RecycleBuffer(statePtr, bufPtr, mustDiscard) if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { statePtr->inQueueHead = bufPtr; statePtr->inQueueTail = bufPtr; - goto keepit; + goto keepBuffer; } if (statePtr->saveInBufPtr == (ChannelBuffer *) NULL) { statePtr->saveInBufPtr = bufPtr; - goto keepit; + goto keepBuffer; } } @@ -1897,7 +1866,7 @@ RecycleBuffer(statePtr, bufPtr, mustDiscard) if (statePtr->flags & TCL_WRITABLE) { if (statePtr->curOutPtr == (ChannelBuffer *) NULL) { statePtr->curOutPtr = bufPtr; - goto keepit; + goto keepBuffer; } } @@ -1908,7 +1877,7 @@ RecycleBuffer(statePtr, bufPtr, mustDiscard) ckfree((char *) bufPtr); return; - keepit: + keepBuffer: bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextPtr = (ChannelBuffer *) NULL; @@ -1950,8 +1919,8 @@ DiscardOutputQueued(statePtr) * * CheckForDeadChannel -- * - * This function checks is a given channel is Dead. - * (A channel that has been closed but not yet deallocated.) + * This function checks is a given channel is Dead (a channel that has + * been closed but not yet deallocated.) * * Results: * True (1) if channel is Dead, False (0) if channel is Ok @@ -1972,7 +1941,7 @@ CheckForDeadChannel(interp, statePtr) if (interp) { Tcl_AppendResult(interp, "unable to access channel: invalid channel", - (char *) NULL); + (char *) NULL); } return 1; } @@ -1989,13 +1958,13 @@ CheckForDeadChannel(interp, statePtr) * event handler to flush channel output asynchronously. * * Results: - * 0 if successful, else the error code that was returned by the - * channel type operation. + * 0 if successful, else the error code that was returned by the channel + * type operation. * * Side effects: - * May produce output on a channel. May block indefinitely if the - * channel is synchronous. May schedule an async flush on the channel. - * May recycle memory for buffers in the output queue. + * May produce output on a channel. May block indefinitely if the channel + * is synchronous. May schedule an async flush on the channel. May + * recycle memory for buffers in the output queue. * *---------------------------------------------------------------------- */ @@ -2004,9 +1973,9 @@ static int FlushChannel(interp, chanPtr, calledFromAsyncFlush) Tcl_Interp *interp; /* For error reporting during close. */ Channel *chanPtr; /* The channel to flush on. */ - int calledFromAsyncFlush; /* If nonzero then we are being - * called from an asynchronous - * flush callback. */ + int calledFromAsyncFlush; /* If nonzero then we are being called + * from an asynchronous flush + * callback. */ { ChannelState *statePtr = chanPtr->state; /* State of the channel stack. */ @@ -2018,14 +1987,14 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) * written in current round. */ int errorCode = 0; /* Stores POSIX error codes from * channel driver operations. */ - int wroteSome = 0; /* Set to one if any data was - * written to the driver. */ + int wroteSome = 0; /* Set to one if any data was written + * to the driver. */ /* - * Prevent writing on a dead channel -- a channel that has been closed - * but not yet deallocated. This can occur if the exit handler for the - * channel deallocation runs before all channels are deregistered in - * all interpreters. + * Prevent writing on a dead channel -- a channel that has been closed but + * not yet deallocated. This can occur if the exit handler for the channel + * deallocation runs before all channels are deregistered in all + * interpreters. */ if (CheckForDeadChannel(interp, statePtr)) { @@ -2033,12 +2002,11 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } /* - * Loop over the queued buffers and attempt to flush as - * much as possible of the queued output to the channel. + * Loop over the queued buffers and attempt to flush as much as possible + * of the queued output to the channel. */ while (1) { - /* * If the queue is empty and there is a ready current buffer, OR if * the current buffer is full, then move the current buffer to the @@ -2062,8 +2030,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) bufPtr = statePtr->outQueueHead; /* - * If we are not being called from an async flush and an async - * flush is active, we just return without producing any output. + * If we are not being called from an async flush and an async flush + * is active, we just return without producing any output. */ if ((!calledFromAsyncFlush) && @@ -2106,16 +2074,16 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } /* - * If the channel is non-blocking and we would have blocked, - * start a background flushing handler and break out of the loop. + * If the channel is non-blocking and we would have blocked, start + * a background flushing handler and break out of the loop. */ if ((errorCode == EWOULDBLOCK) || (errorCode == EAGAIN)) { /* - * This used to check for CHANNEL_NONBLOCKING, and panic - * if the channel was blocking. However, it appears - * that setting stdin to -blocking 0 has some effect on - * the stdout when it's a tty channel (dup'ed underneath) + * This used to check for CHANNEL_NONBLOCKING, and panic if + * the channel was blocking. However, it appears that setting + * stdin to -blocking 0 has some effect on the stdout when + * it's a tty channel (dup'ed underneath) */ if (!(statePtr->flags & BG_FLUSH_SCHEDULED)) { @@ -2140,8 +2108,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) /* * Casting away CONST here is safe because the - * TCL_VOLATILE flag guarantees CONST treatment - * of the Posix error string. + * TCL_VOLATILE flag guarantees CONST treatment of the + * Posix error string. */ Tcl_SetResult(interp, @@ -2150,8 +2118,8 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } /* - * When we get an error we throw away all the output - * currently queued. + * When we get an error we throw away all the output currently + * queued. */ DiscardOutputQueued(statePtr); @@ -2177,9 +2145,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) /* * If we wrote some data while flushing in the background, we are done. - * We can't finish the background flush until we run out of data and - * the channel becomes writable again. This ensures that all of the - * pending data has been flushed at the system level. + * We can't finish the background flush until we run out of data and the + * channel becomes writable again. This ensures that all of the pending + * data has been flushed at the system level. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { @@ -2193,9 +2161,9 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) } /* - * If the channel is flagged as closed, delete it when the refCount - * drops to zero, the output queue is empty and there is no output - * in the current output buffer. + * If the channel is flagged as closed, delete it when the refCount drops + * to zero, the output queue is empty and there is no output in the + * current output buffer. */ if ((statePtr->flags & CHANNEL_CLOSED) && (statePtr->refCount <= 0) && @@ -2219,15 +2187,15 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) * elements of the NEXT channel into the TOP channel, in essence * unstacking the channel. The NEXT channel will then be freed. * - * If the channel was not stacked, then we will free all the bits - * for the TOP channel, including the data structure itself. + * If the channel was not stacked, then we will free all the bits for the + * TOP channel, including the data structure itself. * * Results: * 1 if the channel was stacked, 0 otherwise. * * Side effects: - * May close the actual channel; may free memory. - * May change the value of errno. + * May close the actual channel, may free memory, may change the value of + * errno. * *---------------------------------------------------------------------- */ @@ -2264,8 +2232,7 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * The caller guarantees that there are no more buffers - * queued for output. + * The caller guarantees that there are no more buffers queued for output. */ if (statePtr->outQueueHead != (ChannelBuffer *) NULL) { @@ -2273,8 +2240,8 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * If the EOF character is set in the channel, append that to the - * output device. + * If the EOF character is set in the channel, append that to the output + * device. */ if ((statePtr->outEofChar != 0) && (statePtr->flags & TCL_WRITABLE)) { @@ -2302,9 +2269,8 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * Some resources can be cleared only if the bottom channel - * in a stack is closed. All the other channels in the stack - * are not allowed to remove. + * Some resources can be cleared only if the bottom channel in a stack is + * closed. All the other channels in the stack are not allowed to remove. */ if (chanPtr == statePtr->bottomChanPtr) { @@ -2321,8 +2287,8 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * If we are being called synchronously, report either - * any latent error on the channel or the current error. + * If we are being called synchronously, report either any latent error on + * the channel or the current error. */ if (statePtr->unreportedError != 0) { @@ -2360,11 +2326,10 @@ CloseChannel(interp, chanPtr, errorCode) } /* - * There is only the TOP Channel, so we free the remaining - * pointers we have and then ourselves. Since this is the - * last of the channels in the stack, make sure to free the - * ChannelState structure associated with it. We use - * Tcl_EventuallyFree to allow for any last + * There is only the TOP Channel, so we free the remaining pointers we + * have and then ourselves. Since this is the last of the channels in the + * stack, make sure to free the ChannelState structure associated with it. + * We use Tcl_EventuallyFree to allow for any last */ chanPtr->typePtr = NULL; @@ -2380,9 +2345,8 @@ CloseChannel(interp, chanPtr, errorCode) * * Tcl_CutChannel -- * - * Removes a channel from the (thread-)global list of all channels - * (in that thread). This is actually the statePtr for the stack - * of channel. + * Removes a channel from the (thread-)global list of all channels (in + * that thread). This is actually the statePtr for the stack of channel. * * Results: * Nothing. @@ -2391,12 +2355,11 @@ CloseChannel(interp, chanPtr, errorCode) * Resets the field 'nextCSPtr' of the specified channel state to NULL. * * NOTE: - * The channel to cut out of the list must not be referenced - * in any interpreter. This is something this procedure cannot - * check (despite the refcount) because the caller usually wants - * fiddle with the channel (like transfering it to a different - * thread) and thus keeps the refcount artifically high to prevent - * its destruction. + * The channel to cut out of the list must not be referenced in any + * interpreter. This is something this procedure cannot check (despite + * the refcount) because the caller usually wants fiddle with the channel + * (like transfering it to a different thread) and thus keeps the + * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ @@ -2416,8 +2379,8 @@ Tcl_CutChannel(chan) Tcl_DriverThreadActionProc *threadActionProc; /* - * Remove this channel from of the list of all channels - * (in the current thread). + * Remove this channel from of the list of all channels (in the current + * thread). */ if (tsdPtr->firstCSPtr && (statePtr == tsdPtr->firstCSPtr)) { @@ -2437,10 +2400,10 @@ Tcl_CutChannel(chan) statePtr->nextCSPtr = (ChannelState *) NULL; /* TIP #218, Channel Thread Actions */ - threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan)); + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); if (threadActionProc != NULL) { - (*threadActionProc) (Tcl_GetChannelInstanceData(chan), - TCL_CHANNEL_THREAD_REMOVE); + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_REMOVE); } } @@ -2449,9 +2412,9 @@ Tcl_CutChannel(chan) * * Tcl_SpliceChannel -- * - * Adds a channel to the (thread-)global list of all channels - * (in that thread). Expects that the field 'nextChanPtr' in - * the channel is set to NULL. + * Adds a channel to the (thread-)global list of all channels (in that + * thread). Expects that the field 'nextChanPtr' in the channel is set to + * NULL. * * Results: * Nothing. @@ -2461,19 +2424,18 @@ Tcl_CutChannel(chan) * * NOTE: * The channel to splice into the list must not be referenced in any - * interpreter. This is something this procedure cannot check - * (despite the refcount) because the caller usually wants figgle - * with the channel (like transfering it to a different thread) - * and thus keeps the refcount artifically high to prevent its - * destruction. + * interpreter. This is something this procedure cannot check (despite + * the refcount) because the caller usually wants figgle with the channel + * (like transfering it to a different thread) and thus keeps the + * refcount artifically high to prevent its destruction. * *---------------------------------------------------------------------- */ void Tcl_SpliceChannel(chan) - Tcl_Channel chan; /* The channel being added. Must - * not be referenced in any + Tcl_Channel chan; /* The channel being added. Must not + * be referenced in any * interpreter. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -2488,18 +2450,18 @@ Tcl_SpliceChannel(chan) tsdPtr->firstCSPtr = statePtr; /* - * TIP #10. Mark the current thread as the new one managing this - * channel. Note: 'Tcl_GetCurrentThread' returns sensible - * values even for a non-threaded core. + * TIP #10. Mark the current thread as the new one managing this channel. + * Note: 'Tcl_GetCurrentThread' returns sensible values even for + * a non-threaded core. */ statePtr->managingThread = Tcl_GetCurrentThread(); /* TIP #218, Channel Thread Actions */ - threadActionProc = Tcl_ChannelThreadActionProc (Tcl_GetChannelType (chan)); + threadActionProc = Tcl_ChannelThreadActionProc(Tcl_GetChannelType(chan)); if (threadActionProc != NULL) { - (*threadActionProc) (Tcl_GetChannelInstanceData(chan), - TCL_CHANNEL_THREAD_INSERT); + (*threadActionProc) (Tcl_GetChannelInstanceData(chan), + TCL_CHANNEL_THREAD_INSERT); } } @@ -2518,9 +2480,9 @@ Tcl_SpliceChannel(chan) * * NOTE: * Tcl_Close removes the channel as far as the user is concerned. - * However, it may continue to exist for a while longer if it has - * a background flush scheduled. The device itself is eventually - * closed and the channel record removed, in CloseChannel, above. + * However, it may continue to exist for a while longer if it has a + * background flush scheduled. The device itself is eventually closed and + * the channel record removed, in CloseChannel, above. * *---------------------------------------------------------------------- */ @@ -2529,12 +2491,12 @@ Tcl_SpliceChannel(chan) int Tcl_Close(interp, chan) Tcl_Interp *interp; /* Interpreter for errors. */ - Tcl_Channel chan; /* The channel being closed. Must - * not be referenced in any + Tcl_Channel chan; /* The channel being closed. Must not + * be referenced in any * interpreter. */ { - CloseCallback *cbPtr; /* Iterate over close callbacks - * for this channel. */ + CloseCallback *cbPtr; /* Iterate over close callbacks for + * this channel. */ Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling FlushChannel. */ @@ -2576,6 +2538,7 @@ Tcl_Close(interp, chan) * When the channel has an escape sequence driven encoding such as * iso2022, the terminated escape sequence must write to the buffer. */ + if ((statePtr->encoding != NULL) && (statePtr->curOutPtr != NULL) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; @@ -2607,8 +2570,8 @@ Tcl_Close(interp, chan) } /* - * If this channel supports it, close the read side, since we don't need it - * anymore and this will help avoid deadlocks on some channel types. + * If this channel supports it, close the read side, since we don't need + * it anymore and this will help avoid deadlocks on some channel types. */ if (chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) { @@ -2619,9 +2582,9 @@ Tcl_Close(interp, chan) } /* - * The call to FlushChannel will flush any queued output and invoke - * the close function of the channel driver, or it will set up the - * channel to be flushed and closed asynchronously. + * The call to FlushChannel will flush any queued output and invoke the + * close function of the channel driver, or it will set up the channel to + * be flushed and closed asynchronously. */ statePtr->flags |= CHANNEL_CLOSED; @@ -2669,8 +2632,8 @@ Tcl_ClearChannelHandlers(channel) chanPtr = statePtr->topChanPtr; /* - * Remove any references to channel handlers for this channel that - * may be about to be invoked. + * Remove any references to channel handlers for this channel that may be + * about to be invoked. */ for (nhPtr = tsdPtr->nestedHandlerPtr; @@ -2683,8 +2646,7 @@ Tcl_ClearChannelHandlers(channel) } /* - * Remove all the channel handler records attached to the channel - * itself. + * Remove all the channel handler records attached to the channel itself. */ for (chPtr = statePtr->chPtr; @@ -2702,10 +2664,10 @@ Tcl_ClearChannelHandlers(channel) StopCopy(statePtr->csPtr); /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. + * Must set the interest mask now to 0, otherwise infinite loops will + * occur if Tcl_DoOneEvent is called before the channel is finally deleted + * in FlushChannel. This can happen if the channel has a background flush + * active. */ statePtr->interestMask = 0; @@ -2729,11 +2691,11 @@ Tcl_ClearChannelHandlers(channel) * * Tcl_Write -- * - * Puts a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * Puts a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. Compensates stacking, i.e. will redirect the data from + * the specified channel to the topmost channel in a stack. * * No encoding conversions are applied to the bytes being read. * @@ -2780,11 +2742,11 @@ Tcl_Write(chan, src, srcLen) * * Tcl_WriteRaw -- * - * Puts a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Writes directly to the driver of the channel, - * does not compensate for stacking. + * Puts a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. Writes directly to the driver of the channel, does not + * compensate for stacking. * * No encoding conversions are applied to the bytes being read. * @@ -2839,11 +2801,11 @@ Tcl_WriteRaw(chan, src, srcLen) * Tcl_WriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for - * output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * using the channel's current encoding, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering + * mode. Compensates stacking, i.e. will redirect the data from the + * specified channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2859,8 +2821,9 @@ Tcl_WriteRaw(chan, src, srcLen) int Tcl_WriteChars(chan, src, len) Tcl_Channel chan; /* The channel to buffer output for. */ - CONST char *src; /* UTF-8 characters to queue in output buffer. */ - int len; /* Length of string in bytes, or < 0 for + CONST char *src; /* UTF-8 characters to queue in output + * buffer. */ + int len; /* Length of string in bytes, or < 0 for * strlen(). */ { ChannelState *statePtr; /* state info for channel */ @@ -2880,11 +2843,11 @@ Tcl_WriteChars(chan, src, len) * DoWriteChars -- * * Takes a sequence of UTF-8 characters and converts them for output - * using the channel's current encoding, may queue the buffer for - * output if it gets full, and also remembers whether the current - * buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. Compensates stacking, i.e. will redirect the - * data from the specified channel to the topmost channel in a stack. + * using the channel's current encoding, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering mode. + * Compensates stacking, i.e. will redirect the data from the specified + * channel to the topmost channel in a stack. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -2900,8 +2863,9 @@ Tcl_WriteChars(chan, src, len) static int DoWriteChars(chanPtr, src, len) Channel *chanPtr; /* The channel to buffer output for. */ - CONST char *src; /* UTF-8 characters to queue in output buffer. */ - int len; /* Length of string in bytes, or < 0 for + CONST char *src; /* UTF-8 characters to queue in output + * buffer. */ + int len; /* Length of string in bytes, or < 0 for * strlen(). */ { /* @@ -2918,8 +2882,8 @@ DoWriteChars(chanPtr, src, len) } if (statePtr->encoding == NULL) { /* - * Inefficient way to convert UTF-8 to byte-array, but the - * code parallels the way it is done for objects. + * Inefficient way to convert UTF-8 to byte-array, but the code + * parallels the way it is done for objects. */ Tcl_Obj *objPtr; @@ -2939,17 +2903,17 @@ DoWriteChars(chanPtr, src, len) * * Tcl_WriteObj -- * - * Takes the Tcl object and queues its contents for output. If the - * encoding of the channel is NULL, takes the byte-array representation - * of the object and queues those bytes for output. Otherwise, takes - * the characters in the UTF-8 (string) representation of the object - * and converts them for output using the channel's current encoding. - * May flush internal buffers to output if one becomes full or is ready - * for some other reason, e.g. if it contains a newline and the channel - * is in line buffering mode. + * Takes the Tcl object and queues its contents for output. If the + * encoding of the channel is NULL, takes the byte-array representation + * of the object and queues those bytes for output. Otherwise, takes the + * characters in the UTF-8 (string) representation of the object and + * converts them for output using the channel's current encoding. May + * flush internal buffers to output if one becomes full or is ready for + * some other reason, e.g. if it contains a newline and the channel is in + * line buffering mode. * * Results: - * The number of bytes written or -1 in case of error. If -1, + * The number of bytes written or -1 in case of error. If -1, * Tcl_GetErrno() will return the error code. * * Side effects: @@ -2967,6 +2931,7 @@ Tcl_WriteObj(chan, objPtr) /* * Always use the topmost channel of the stack */ + Channel *chanPtr; ChannelState *statePtr; /* state info for channel */ char *src; @@ -2992,10 +2957,10 @@ Tcl_WriteObj(chan, objPtr) * * WriteBytes -- * - * Write a sequence of bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * Write a sequence of bytes into an output buffer, may queue the buffer + * for output if it gets full, and also remembers whether the current + * buffer is ready e.g. if it contains a newline and we are in line + * buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -3024,8 +2989,8 @@ WriteBytes(chanPtr, src, srcLen) savedLF = 0; /* - * Loop over all bytes in src, storing them in output buffer with - * proper EOL translation. + * Loop over all bytes in src, storing them in output buffer with proper + * EOL translation. */ while (srcLen + savedLF > 0) { @@ -3045,8 +3010,8 @@ WriteBytes(chanPtr, src, srcLen) if (savedLF) { /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in this buffer. If the channel is + * A '\n' was left over from last call to TranslateOutputEOL() and + * we need to store it in this buffer. If the channel is * line-based, we will need to flush it. */ @@ -3081,11 +3046,10 @@ WriteBytes(chanPtr, src, srcLen) * * WriteChars -- * - * Convert UTF-8 bytes to the channel's external encoding and - * write the produced bytes into an output buffer, may queue the - * buffer for output if it gets full, and also remembers whether the - * current buffer is ready e.g. if it contains a newline and we are in - * line buffering mode. + * Convert UTF-8 bytes to the channel's external encoding and write the + * produced bytes into an output buffer, may queue the buffer for output + * if it gets full, and also remembers whether the current buffer is + * ready e.g. if it contains a newline and we are in line buffering mode. * * Results: * The number of bytes written or -1 in case of error. If -1, @@ -3144,10 +3108,10 @@ WriteChars(chanPtr, src, srcLen) if (savedLF) { /* - * A '\n' was left over from last call to TranslateOutputEOL() - * and we need to store it in the staging buffer. If the - * channel is line-based, we will need to flush the output - * buffer (after translating the staging buffer). + * A '\n' was left over from last call to TranslateOutputEOL() and + * we need to store it in the staging buffer. If the channel is + * line-based, we will need to flush the output buffer (after + * translating the staging buffer). */ *stage++ = '\n'; @@ -3185,9 +3149,8 @@ WriteChars(chanPtr, src, srcLen) if (saved != 0) { /* - * Here's some translated bytes left over from the last - * buffer that we need to stick at the beginning of this - * buffer. + * Here's some translated bytes left over from the last buffer + * that we need to stick at the beginning of this buffer. */ memcpy((VOID *) dst, (VOID *) safe, (size_t) saved); @@ -3240,11 +3203,10 @@ WriteChars(chanPtr, src, srcLen) if (bufPtr->nextAdded > bufPtr->bufLength) { /* * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that - * crossed the end of the output buffer, so that we would - * get a completely full buffer before flushing it. The - * extra bytes will be moved to the beginning of the next - * buffer. + * allowed the translation to produce a character that crossed + * the end of the output buffer, so that we would get a + * completely full buffer before flushing it. The extra bytes + * will be moved to the beginning of the next buffer. */ saved = bufPtr->nextAdded - bufPtr->bufLength; @@ -3274,8 +3236,9 @@ WriteChars(chanPtr, src, srcLen) } } - /* If nothing was written and it happened because there was no progress - * in the UTF conversion, we throw an error. + /* + * If nothing was written and it happened because there was no progress in + * the UTF conversion, we throw an error. */ if (!consumedSomething && (total == 0)) { @@ -3290,37 +3253,36 @@ WriteChars(chanPtr, src, srcLen) * * TranslateOutputEOL -- * - * Helper function for WriteBytes() and WriteChars(). Converts the - * '\n' characters in the source buffer into the appropriate EOL - * form specified by the output translation mode. + * Helper function for WriteBytes() and WriteChars(). Converts the '\n' + * characters in the source buffer into the appropriate EOL form + * specified by the output translation mode. * - * EOL translation stops either when the source buffer is empty - * or the output buffer is full. + * EOL translation stops either when the source buffer is empty or the + * output buffer is full. * - * When converting to CRLF mode and there is only 1 byte left in - * the output buffer, this routine stores the '\r' in the last - * byte and then stores the '\n' in the byte just past the end of the - * buffer. The caller is responsible for passing in a buffer that - * is large enough to hold the extra byte. + * When converting to CRLF mode and there is only 1 byte left in the + * output buffer, this routine stores the '\r' in the last byte and then + * stores the '\n' in the byte just past the end of the buffer. The + * caller is responsible for passing in a buffer that is large enough to + * hold the extra byte. * * Results: - * The return value is 1 if a '\n' was translated from the source - * buffer, or 0 otherwise -- this can be used by the caller to - * decide to flush a line-based channel even though the channel - * buffer is not full. + * The return value is 1 if a '\n' was translated from the source buffer, + * or 0 otherwise -- this can be used by the caller to decide to flush a + * line-based channel even though the channel buffer is not full. * - * *dstLenPtr is filled with how many bytes of the output buffer - * were used. As mentioned above, this can be one more that - * the output buffer's specified length if a CRLF was stored. + * *dstLenPtr is filled with how many bytes of the output buffer were + * used. As mentioned above, this can be one more that the output + * buffer's specified length if a CRLF was stored. * - * *srcLenPtr is filled with how many bytes of the source buffer - * were consumed. + * *srcLenPtr is filled with how many bytes of the source buffer were + * consumed. * * Side effects: - * It may be obvious, but bears mentioning that when converting - * in CRLF mode (which requires two bytes of storage in the output - * buffer), the number of bytes consumed from the source buffer - * will be less than the number of bytes stored in the output buffer. + * It may be obvious, but bears mentioning that when converting in CRLF + * mode (which requires two bytes of storage in the output buffer), the + * number of bytes consumed from the source buffer will be less than the + * number of bytes stored in the output buffer. * *--------------------------------------------------------------------------- */ @@ -3336,9 +3298,9 @@ TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr) int *dstLenPtr; /* On entry, the maximum length of output * buffer in bytes. On exit, the number of * bytes actually used in output buffer. */ - int *srcLenPtr; /* On entry, the length of source buffer. - * On exit, the number of bytes read from - * the source buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. On + * exit, the number of bytes read from the + * source buffer. */ { char *dstEnd; int srcLen, newlineFound; @@ -3347,68 +3309,64 @@ TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr) srcLen = *srcLenPtr; switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: { - for (dstEnd = dst + srcLen; dst < dstEnd; ) { - if (*src == '\n') { - newlineFound = 1; - } - *dst++ = *src++; + case TCL_TRANSLATE_LF: + for (dstEnd = dst + srcLen; dst < dstEnd; ) { + if (*src == '\n') { + newlineFound = 1; } - *dstLenPtr = srcLen; - break; - } - case TCL_TRANSLATE_CR: { - for (dstEnd = dst + srcLen; dst < dstEnd;) { - if (*src == '\n') { - *dst++ = '\r'; - newlineFound = 1; - src++; - } else { - *dst++ = *src++; - } + *dst++ = *src++; + } + *dstLenPtr = srcLen; + break; + case TCL_TRANSLATE_CR: + for (dstEnd = dst + srcLen; dst < dstEnd;) { + if (*src == '\n') { + *dst++ = '\r'; + newlineFound = 1; + src++; + } else { + *dst++ = *src++; } - *dstLenPtr = srcLen; - break; } - case TCL_TRANSLATE_CRLF: { - /* - * Since this causes the number of bytes to grow, we - * start off trying to put 'srcLen' bytes into the - * output buffer, but allow it to store more bytes, as - * long as there's still source bytes and room in the - * output buffer. - */ + *dstLenPtr = srcLen; + break; + case TCL_TRANSLATE_CRLF: { + /* + * Since this causes the number of bytes to grow, we start off trying + * to put 'srcLen' bytes into the output buffer, but allow it to store + * more bytes, as long as there's still source bytes and room in the + * output buffer. + */ - char *dstStart, *dstMax; - CONST char *srcStart; + char *dstStart, *dstMax; + CONST char *srcStart; - dstStart = dst; - dstMax = dst + *dstLenPtr; + dstStart = dst; + dstMax = dst + *dstLenPtr; - srcStart = src; + srcStart = src; - if (srcLen < *dstLenPtr) { - dstEnd = dst + srcLen; - } else { - dstEnd = dst + *dstLenPtr; - } - while (dst < dstEnd) { - if (*src == '\n') { - if (dstEnd < dstMax) { - dstEnd++; - } - *dst++ = '\r'; - newlineFound = 1; + if (srcLen < *dstLenPtr) { + dstEnd = dst + srcLen; + } else { + dstEnd = dst + *dstLenPtr; + } + while (dst < dstEnd) { + if (*src == '\n') { + if (dstEnd < dstMax) { + dstEnd++; } - *dst++ = *src++; + *dst++ = '\r'; + newlineFound = 1; } - *srcLenPtr = src - srcStart; - *dstLenPtr = dst - dstStart; - break; - } - default: { - break; + *dst++ = *src++; } + *srcLenPtr = src - srcStart; + *dstLenPtr = dst - dstStart; + break; + } + default: + break; } return newlineFound; } @@ -3418,12 +3376,12 @@ TranslateOutputEOL(statePtr, dst, src, dstLenPtr, srcLenPtr) * * CheckFlush -- * - * Helper function for WriteBytes() and WriteChars(). If the - * channel buffer is ready to be flushed, flush it. + * Helper function for WriteBytes() and WriteChars(). If the channel + * buffer is ready to be flushed, flush it. * * Results: - * The return value is -1 if there was a problem flushing the - * channel buffer, or 0 otherwise. + * The return value is -1 if there was a problem flushing the channel + * buffer, or 0 otherwise. * * Side effects: * The buffer will be recycled if it is flushed. @@ -3435,8 +3393,8 @@ static int CheckFlush(chanPtr, bufPtr, newlineFlag) Channel *chanPtr; /* Channel being read, for buffering mode. */ ChannelBuffer *bufPtr; /* Channel buffer to possibly flush. */ - int newlineFlag; /* Non-zero if a the channel buffer - * contains a newline. */ + int newlineFlag; /* Non-zero if a the channel buffer contains a + * newline. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* @@ -3478,8 +3436,8 @@ CheckFlush(chanPtr, bufPtr, newlineFlag) * error or condition that occurred. * * Side effects: - * May flush output on the channel. May cause input to be consumed - * from the channel. + * May flush output on the channel. May cause input to be consumed from + * the channel. * *--------------------------------------------------------------------------- */ @@ -3512,21 +3470,19 @@ Tcl_Gets(chan, lineRead) * Tcl_GetsObj -- * * Accumulate input from the input channel until end-of-line or - * end-of-file has been seen. Bytes read from the input channel - * are converted to UTF-8 using the encoding specified by the - * channel. + * end-of-file has been seen. Bytes read from the input channel are + * converted to UTF-8 using the encoding specified by the channel. * * Results: * Number of characters accumulated in the object or -1 if error, - * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the - * POSIX error code for the error or condition that occurred. + * blocked, or EOF. If -1, use Tcl_GetErrno() to retrieve the POSIX + * error code for the error or condition that occurred. * * Side effects: * Consumes input from the channel. * - * On reading EOF, leave channel pointing at EOF char. - * On reading EOL, leave channel pointing after EOL, but don't - * return EOL in dst buffer. + * On reading EOF, leave channel pointing at EOF char. On reading EOL, + * leave channel pointing after EOL, but don't return EOL in dst buffer. * *--------------------------------------------------------------------------- */ @@ -3561,8 +3517,8 @@ Tcl_GetsObj(chan, objPtr) encoding = statePtr->encoding; /* - * Preserved so we can restore the channel's state in case we don't - * find a newline in the available input. + * Preserved so we can restore the channel's state in case we don't find a + * newline in the available input. */ Tcl_GetStringFromObj(objPtr, &oldLength); @@ -3575,7 +3531,7 @@ Tcl_GetsObj(chan, objPtr) /* * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't - * produce ByteArray objects. + * produce ByteArray objects. */ if (encoding == NULL) { @@ -3583,8 +3539,8 @@ Tcl_GetsObj(chan, objPtr) } /* - * Object used by FilterInputBytes to keep track of how much data has - * been consumed from the channel buffers. + * Object used by FilterInputBytes to keep track of how much data has been + * consumed from the channel buffers. */ gs.objPtr = objPtr; @@ -3613,8 +3569,8 @@ Tcl_GetsObj(chan, objPtr) } /* - * Remember if EOF char is seen, then look for EOL anyhow, because - * the EOL might be before the EOF char. + * Remember if EOF char is seen, then look for EOL anyhow, because the + * EOL might be before the EOF char. */ if (inEofChar != '\0') { @@ -3633,115 +3589,109 @@ Tcl_GetsObj(chan, objPtr) */ switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\n') { - skip = 1; - goto goteol; - } + case TCL_TRANSLATE_LF: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\n') { + skip = 1; + goto gotEOL; } - break; } - case TCL_TRANSLATE_CR: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - skip = 1; - goto goteol; - } + break; + case TCL_TRANSLATE_CR: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + skip = 1; + goto gotEOL; } - break; } - case TCL_TRANSLATE_CRLF: { - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - eol++; + break; + case TCL_TRANSLATE_CRLF: + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; - /* - * If a CR is at the end of the buffer, - * then check for a LF at the begining - * of the next buffer. - */ + /* + * If a CR is at the end of the buffer, then check for a + * LF at the begining of the next buffer. + */ - if (eol >= dstEnd) { - int offset; - - offset = eol - objPtr->bytes; - dst = dstEnd; - if (FilterInputBytes(chanPtr, &gs) != 0) { - goto restore; - } - dstEnd = dst + gs.bytesWrote; - eol = objPtr->bytes + offset; - if (eol >= dstEnd) { - skip = 0; - goto goteol; - } + if (eol >= dstEnd) { + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + if (FilterInputBytes(chanPtr, &gs) != 0) { + goto restore; } - if (*eol == '\n') { - eol--; - skip = 2; - goto goteol; + dstEnd = dst + gs.bytesWrote; + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + skip = 0; + goto gotEOL; } } + if (*eol == '\n') { + eol--; + skip = 2; + goto gotEOL; + } + } + } + break; + case TCL_TRANSLATE_AUTO: + eol = dst; + skip = 1; + if (statePtr->flags & INPUT_SAW_CR) { + statePtr->flags &= ~INPUT_SAW_CR; + if ((eol < dstEnd) && (*eol == '\n')) { + /* + * Skip the raw bytes that make up the '\n'. + */ + + char tmp[1 + TCL_UTF_MAX]; + int rawRead; + + bufPtr = gs.bufPtr; + Tcl_ExternalToUtf(NULL, gs.encoding, + bufPtr->buf + bufPtr->nextRemoved, gs.rawRead, + statePtr->inputEncodingFlags, &gs.state, tmp, + 1 + TCL_UTF_MAX, &rawRead, NULL, NULL); + bufPtr->nextRemoved += rawRead; + gs.rawRead -= rawRead; + gs.bytesWrote--; + gs.charsWrote--; + memmove(dst, dst + 1, (size_t) (dstEnd - dst)); + dstEnd--; } - break; } - case TCL_TRANSLATE_AUTO: { - eol = dst; - skip = 1; - if (statePtr->flags & INPUT_SAW_CR) { - statePtr->flags &= ~INPUT_SAW_CR; - if ((eol < dstEnd) && (*eol == '\n')) { + for (eol = dst; eol < dstEnd; eol++) { + if (*eol == '\r') { + eol++; + if (eol == dstEnd) { /* - * Skip the raw bytes that make up the '\n'. + * If buffer ended on \r, peek ahead to see if a \n is + * available. */ - char tmp[1 + TCL_UTF_MAX]; - int rawRead; - - bufPtr = gs.bufPtr; - Tcl_ExternalToUtf(NULL, gs.encoding, - bufPtr->buf + bufPtr->nextRemoved, - gs.rawRead, statePtr->inputEncodingFlags, - &gs.state, tmp, 1 + TCL_UTF_MAX, &rawRead, - NULL, NULL); - bufPtr->nextRemoved += rawRead; - gs.rawRead -= rawRead; - gs.bytesWrote--; - gs.charsWrote--; - memmove(dst, dst + 1, (size_t) (dstEnd - dst)); - dstEnd--; - } - } - for (eol = dst; eol < dstEnd; eol++) { - if (*eol == '\r') { - eol++; - if (eol == dstEnd) { - /* - * If buffer ended on \r, peek ahead to see if a - * \n is available. - */ - - int offset; - - offset = eol - objPtr->bytes; - dst = dstEnd; - PeekAhead(chanPtr, &dstEnd, &gs); - eol = objPtr->bytes + offset; - if (eol >= dstEnd) { - eol--; - statePtr->flags |= INPUT_SAW_CR; - goto goteol; - } - } - if (*eol == '\n') { - skip++; + int offset; + + offset = eol - objPtr->bytes; + dst = dstEnd; + PeekAhead(chanPtr, &dstEnd, &gs); + eol = objPtr->bytes + offset; + if (eol >= dstEnd) { + eol--; + statePtr->flags |= INPUT_SAW_CR; + goto gotEOL; } - eol--; - goto goteol; - } else if (*eol == '\n') { - goto goteol; } + if (*eol == '\n') { + skip++; + } + eol--; + goto gotEOL; + } else if (*eol == '\n') { + goto gotEOL; } } } @@ -3770,20 +3720,20 @@ Tcl_GetsObj(chan, objPtr) copiedTotal = -1; goto done; } - goto goteol; + goto gotEOL; } dst = dstEnd; } /* - * Found EOL or EOF, but the output buffer may now contain too many - * UTF-8 characters. We need to know how many raw bytes correspond to - * the number of UTF-8 characters we want, plus how many raw bytes - * correspond to the character(s) making up EOL (if any), so we can - * remove the correct number of bytes from the channel buffer. + * Found EOL or EOF, but the output buffer may now contain too many UTF-8 + * characters. We need to know how many raw bytes correspond to the + * number of UTF-8 characters we want, plus how many raw bytes correspond + * to the character(s) making up EOL (if any), so we can remove the + * correct number of bytes from the channel buffer. */ - goteol: + gotEOL: bufPtr = gs.bufPtr; statePtr->inputEncodingState = gs.state; Tcl_ExternalToUtf(NULL, gs.encoding, bufPtr->buf + bufPtr->nextRemoved, @@ -3805,11 +3755,11 @@ Tcl_GetsObj(chan, objPtr) /* * Couldn't get a complete line. This only happens if we get a error - * reading from the channel or we are non-blocking and there wasn't - * an EOL or EOF in the data available. + * reading from the channel or we are non-blocking and there wasn't an EOL + * or EOF in the data available. */ - restore: + restore: bufPtr = statePtr->inQueueHead; bufPtr->nextRemoved = oldRemoved; @@ -3824,11 +3774,11 @@ Tcl_GetsObj(chan, objPtr) /* * We didn't get a complete line so we need to indicate to UpdateInterest - * that the gets blocked. It will wait for more data instead of firing - * a timer, avoiding a busy wait. This is where we are assuming that the - * next operation is a gets. No more file events will be delivered on - * this channel until new data arrives or some operation is performed - * on the channel (e.g. gets, read, fconfigure) that changes the blocking + * that the gets blocked. It will wait for more data instead of firing a + * timer, avoiding a busy wait. This is where we are assuming that the + * next operation is a gets. No more file events will be delivered on + * this channel until new data arrives or some operation is performed on + * the channel (e.g. gets, read, fconfigure) that changes the blocking * state. Note that this means a file event will not be delivered even * though a read would be able to consume the buffered data. */ @@ -3836,12 +3786,12 @@ Tcl_GetsObj(chan, objPtr) statePtr->flags |= CHANNEL_NEED_MORE_DATA; copiedTotal = -1; - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copiedTotal; } @@ -3851,21 +3801,21 @@ Tcl_GetsObj(chan, objPtr) * * FilterInputBytes -- * - * Helper function for Tcl_GetsObj. Produces UTF-8 characters from - * raw bytes read from the channel. + * Helper function for Tcl_GetsObj. Produces UTF-8 characters from raw + * bytes read from the channel. * - * Consumes available bytes from channel buffers. When channel - * buffers are exhausted, reads more bytes from channel device into - * a new channel buffer. It is the caller's responsibility to - * free the channel buffers that have been exhausted. + * Consumes available bytes from channel buffers. When channel buffers + * are exhausted, reads more bytes from channel device into a new channel + * buffer. It is the caller's responsibility to free the channel buffers + * that have been exhausted. * * Results: - * The return value is -1 if there was an error reading from the - * channel, 0 otherwise. + * The return value is -1 if there was an error reading from the channel, + * 0 otherwise. * * Side effects: - * Status object keeps track of how much data from channel buffers - * has been consumed and where UTF-8 bytes should be stored. + * Status object keeps track of how much data from channel buffers has + * been consumed and where UTF-8 bytes should be stored. * *--------------------------------------------------------------------------- */ @@ -3881,9 +3831,9 @@ FilterInputBytes(chanPtr, gsPtr) char *dst; int offset, toRead, dstNeeded, spaceLeft, result, rawLen, length; Tcl_Obj *objPtr; -#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert - * at a time. Since we don't know a priori - * how many bytes of storage this many source +#define ENCODING_LINESIZE 20 /* Lower bound on how many bytes to convert at + * a time. Since we don't know a priori how + * many bytes of storage this many source * bytes will use, we actually need at least * ENCODING_LINESIZE * TCL_MAX_UTF bytes of * room. */ @@ -3906,12 +3856,12 @@ FilterInputBytes(chanPtr, gsPtr) if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still hasn't - * seen EOL. Need to read more bytes from the channel device. - * Side effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still hasn't seen + * EOL. Need to read more bytes from the channel device. Side effect + * is to allocate another channel buffer. */ - read: + read: if (statePtr->flags & CHANNEL_BLOCKED) { if (statePtr->flags & CHANNEL_NONBLOCKING) { gsPtr->charsWrote = 0; @@ -3975,8 +3925,8 @@ FilterInputBytes(chanPtr, gsPtr) if (result == TCL_CONVERT_MULTIBYTE) { /* * The last few bytes in this channel buffer were the start of a - * multibyte sequence. If this buffer was full, then move them to - * the next buffer so the bytes will be contiguous. + * multibyte sequence. If this buffer was full, then move them to the + * next buffer so the bytes will be contiguous. */ ChannelBuffer *nextPtr; @@ -3999,8 +3949,8 @@ FilterInputBytes(chanPtr, gsPtr) bufPtr->nextRemoved = bufPtr->nextAdded; } else { /* - * There are no more cached raw bytes left. See if we can - * get some more. + * There are no more cached raw bytes left. See if we can get + * some more. */ goto read; @@ -4028,9 +3978,9 @@ FilterInputBytes(chanPtr, gsPtr) * * PeekAhead -- * - * Helper function used by Tcl_GetsObj(). Called when we've seen a - * \r at the end of the UTF-8 string and want to look ahead one - * character to see if it is a \n. + * Helper function used by Tcl_GetsObj(). Called when we've seen a \r at + * the end of the UTF-8 string and want to look ahead one character to + * see if it is a \n. * * Results: * *gsPtr->dstPtr is filled with a pointer to the start of the range of @@ -4048,8 +3998,8 @@ FilterInputBytes(chanPtr, gsPtr) static void PeekAhead(chanPtr, dstEndPtr, gsPtr) Channel *chanPtr; /* The channel to read. */ - char **dstEndPtr; /* Filled with pointer to end of new range - * of UTF-8 characters. */ + char **dstEndPtr; /* Filled with pointer to end of new range of + * UTF-8 characters. */ GetsState *gsPtr; /* Current state of gets operation. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ @@ -4061,10 +4011,10 @@ PeekAhead(chanPtr, dstEndPtr, gsPtr) /* * If there's any more raw input that's still buffered, we'll peek into - * that. Otherwise, only get more data from the channel driver if it - * looks like there might actually be more data. The assumption is that - * if the channel buffer is filled right up to the end, then there - * might be more data to read. + * that. Otherwise, only get more data from the channel driver if it looks + * like there might actually be more data. The assumption is that if the + * channel buffer is filled right up to the end, then there might be more + * data to read. */ blockModeProc = NULL; @@ -4099,7 +4049,7 @@ PeekAhead(chanPtr, dstEndPtr, gsPtr) } return; - cleanup: + cleanup: bufPtr->nextRemoved += gsPtr->rawRead; gsPtr->rawRead = 0; gsPtr->totalChars += gsPtr->charsWrote; @@ -4112,8 +4062,8 @@ PeekAhead(chanPtr, dstEndPtr, gsPtr) * * CommonGetsCleanup -- * - * Helper function for Tcl_GetsObj() to restore the channel after - * a "gets" operation. + * Helper function for Tcl_GetsObj() to restore the channel after a + * "gets" operation. * * Results: * None. @@ -4178,16 +4128,16 @@ CommonGetsCleanup(chanPtr, encoding) * * Tcl_Read -- * - * Reads a given number of bytes from a channel. EOL and EOF - * translation is done on the bytes being read, so the number - * of bytes consumed from the channel may not be equal to the - * number of bytes stored in the destination buffer. + * Reads a given number of bytes from a channel. EOL and EOF translation + * is done on the bytes being read, so the number of bytes consumed from + * the channel may not be equal to the number of bytes stored in the + * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. @@ -4201,7 +4151,7 @@ Tcl_Read(chan, dst, bytesToRead) char *dst; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { - Channel *chanPtr = (Channel *) chan; + Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* @@ -4222,16 +4172,16 @@ Tcl_Read(chan, dst, bytesToRead) * * Tcl_ReadRaw -- * - * Reads a given number of bytes from a channel. EOL and EOF - * translation is done on the bytes being read, so the number - * of bytes consumed from the channel may not be equal to the - * number of bytes stored in the destination buffer. + * Reads a given number of bytes from a channel. EOL and EOF translation + * is done on the bytes being read, so the number of bytes consumed from + * the channel may not be equal to the number of bytes stored in the + * destination buffer. * * No encoding conversions are applied to the bytes being read. * * Results: - * The number of bytes read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of bytes read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. @@ -4245,7 +4195,7 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) char *bufPtr; /* Where to store input read. */ int bytesToRead; /* Maximum number of bytes to read. */ { - Channel *chanPtr = (Channel *) chan; + Channel *chanPtr = (Channel *) chan; ChannelState *statePtr = chanPtr->state; /* state info for channel */ int nread, result; int copied, copiedNow; @@ -4253,9 +4203,9 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) /* * The check below does too much because it will reject a call to this * function with a channel which is part of an 'fcopy'. But we have to - * allow this here or else the chaining in the transformation drivers - * will fail with 'file busy' error instead of retrieving and - * transforming the data to copy. + * allow this here or else the chaining in the transformation drivers will + * fail with 'file busy' error instead of retrieving and transforming the + * data to copy. * * We let the check procedure now believe that there is no fcopy in * progress. A better solution than this might be an additional flag @@ -4267,9 +4217,9 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) } /* - * Check for information in the push-back buffers. If there is - * some, use it. Go to the driver only if there is none (anymore) - * and the caller requests more bytes. + * Check for information in the push-back buffers. If there is some, use + * it. Go to the driver only if there is none (anymore) and the caller + * requests more bytes. */ for (copied = 0; copied < bytesToRead; copied += copiedNow) { @@ -4287,28 +4237,30 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) } #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* [SF Tcl Bug 943274]. Better emulation of non-blocking - * channels for channels without BlockModeProc, by keeping - * track of true fileevents generated by the OS == Data - * waiting and reading if and only if we are sure to have - * data. + /* + * [SF Tcl Bug 943274]. Better emulation of non-blocking channels + * for channels without BlockModeProc, by keeping track of true + * fileevents generated by the OS == Data waiting and reading if + * and only if we are sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && (Tcl_ChannelBlockModeProc(chanPtr->typePtr) == NULL) && !(statePtr->flags & CHANNEL_HAS_MORE_DATA)) { /* - * We bypass the driver, it would block, as no data is - * available + * We bypass the driver; it would block as no data is + * available. */ + nread = -1; result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + /* - * Now go to the driver to get as much as is possible to - * fill the remaining request. Do all the error handling - * by ourselves. The code was stolen from 'GetInput' and + * Now go to the driver to get as much as is possible to fill + * the remaining request. Do all the error handling by + * ourselves. The code was stolen from 'GetInput' and * slightly adapted (different return value here). * * The case of 'bytesToRead == 0' at this point cannot happen. @@ -4316,9 +4268,11 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr + copied, bytesToRead - copied, &result); + #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + if (nread > 0) { /* * If we get a short read, signal up that we may be @@ -4335,16 +4289,18 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= (bytesToRead - copied)) { /* - * [SF Tcl Bug 943274] We have read the available - * data, clear flag. + * [SF Tcl Bug 943274] We have read the available data, + * clear flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + } else if (nread == 0) { statePtr->flags |= CHANNEL_EOF; statePtr->inputEncodingFlags |= TCL_ENCODING_END; + } else if (nread < 0) { if ((result == EWOULDBLOCK) || (result == EAGAIN)) { if (copied > 0) { @@ -4362,13 +4318,13 @@ Tcl_ReadRaw(chan, bufPtr, bytesToRead) Tcl_SetErrno(result); return -1; - } + } return copied + nread; } } -done: + done: return copied; } @@ -4377,16 +4333,16 @@ done: * * Tcl_ReadChars -- * - * Reads from the channel until the requested number of characters - * have been seen, EOF is seen, or the channel would block. EOL - * and EOF translation is done. If reading binary data, the raw - * bytes are wrapped in a Tcl byte array object. Otherwise, the raw - * bytes are converted to UTF-8 using the channel's current encoding - * and stored in a Tcl string object. + * Reads from the channel until the requested number of characters have + * been seen, EOF is seen, or the channel would block. EOL and EOF + * translation is done. If reading binary data, the raw bytes are + * wrapped in a Tcl byte array object. Otherwise, the raw bytes are + * converted to UTF-8 using the channel's current encoding and stored in + * a Tcl string object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. @@ -4398,9 +4354,9 @@ int Tcl_ReadChars(chan, objPtr, toRead, appendFlag) Tcl_Channel chan; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ - int toRead; /* Maximum number of characters to store, - * or -1 to read all available data (up to EOF - * or when channel blocks). */ + int toRead; /* Maximum number of characters to store, or + * -1 to read all available data (up to EOF or + * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents @@ -4432,16 +4388,16 @@ Tcl_ReadChars(chan, objPtr, toRead, appendFlag) * * DoReadChars -- * - * Reads from the channel until the requested number of characters - * have been seen, EOF is seen, or the channel would block. EOL - * and EOF translation is done. If reading binary data, the raw - * bytes are wrapped in a Tcl byte array object. Otherwise, the raw - * bytes are converted to UTF-8 using the channel's current encoding - * and stored in a Tcl string object. + * Reads from the channel until the requested number of characters have + * been seen, EOF is seen, or the channel would block. EOL and EOF + * translation is done. If reading binary data, the raw bytes are + * wrapped in a Tcl byte array object. Otherwise, the raw bytes are + * converted to UTF-8 using the channel's current encoding and stored in + * a Tcl string object. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. @@ -4453,9 +4409,9 @@ static int DoReadChars(chanPtr, objPtr, toRead, appendFlag) Channel *chanPtr; /* The channel to read. */ Tcl_Obj *objPtr; /* Input data is stored in this object. */ - int toRead; /* Maximum number of characters to store, - * or -1 to read all available data (up to EOF - * or when channel blocks). */ + int toRead; /* Maximum number of characters to store, or + * -1 to read all available data (up to EOF or + * when channel blocks). */ int appendFlag; /* If non-zero, data read from the channel * will be appended to the object. Otherwise, * the data will replace the existing contents @@ -4480,10 +4436,11 @@ DoReadChars(chanPtr, objPtr, toRead, appendFlag) Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); - /* - * We're going to access objPtr->bytes directly, so - * we must ensure that this is actually a string - * object (otherwise it might have been pure Unicode). + + /* + * We're going to access objPtr->bytes directly, so we must ensure + * that this is actually a string object (otherwise it might have + * been pure Unicode). */ Tcl_GetString(objPtr); @@ -4523,6 +4480,7 @@ DoReadChars(chanPtr, objPtr, toRead, appendFlag) } } } + if (copiedNow < 0) { if (statePtr->flags & CHANNEL_EOF) { break; @@ -4546,6 +4504,7 @@ DoReadChars(chanPtr, objPtr, toRead, appendFlag) toRead -= copiedNow; } } + statePtr->flags &= ~CHANNEL_BLOCKED; if (encoding == NULL) { Tcl_SetByteArrayLength(objPtr, offset); @@ -4553,12 +4512,12 @@ DoReadChars(chanPtr, objPtr, toRead, appendFlag) Tcl_SetObjLength(objPtr, offset); } - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copied; } @@ -4567,20 +4526,19 @@ DoReadChars(chanPtr, objPtr, toRead, appendFlag) * * ReadBytes -- * - * Reads from the channel until the requested number of bytes have - * been seen, EOF is seen, or the channel would block. Bytes from - * the channel are stored in objPtr as a ByteArray object. EOL - * and EOF translation are done. + * Reads from the channel until the requested number of bytes have been + * seen, EOF is seen, or the channel would block. Bytes from the channel + * are stored in objPtr as a ByteArray object. EOL and EOF translation + * are done. * - * 'bytesToRead' can safely be a very large number because - * space is only allocated to hold data read from the channel - * as needed. + * 'bytesToRead' can safely be a very large number because space is only + * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of bytes appended to the object - * and *offsetPtr is filled with the total number of bytes in the - * object (greater than the return value if there were already bytes - * in the object). + * The return value is the number of bytes appended to the object and + * *offsetPtr is filled with the total number of bytes in the object + * (greater than the return value if there were already bytes in the + * object). * * Side effects: * None. @@ -4592,22 +4550,21 @@ static int ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) ChannelState *statePtr; /* State of the channel to read. */ Tcl_Obj *objPtr; /* Input data is appended to this ByteArray - * object. Its length is how much space - * has been allocated to hold data, not how - * many bytes of data have been stored in the + * object. Its length is how much space has + * been allocated to hold data, not how many + * bytes of data have been stored in the * object. */ - int bytesToRead; /* Maximum number of bytes to store, - * or < 0 to get all available bytes. - * Bytes are obtained from the first - * buffer in the queue -- even if this number - * is larger than the number of bytes - * available in the first buffer, only the - * bytes from the first buffer are + int bytesToRead; /* Maximum number of bytes to store, or < 0 to + * get all available bytes. Bytes are obtained + * from the first buffer in the queue - even + * if this number is larger than the number of + * bytes available in the first buffer, only + * the bytes from the first buffer are * returned. */ - int *offsetPtr; /* On input, contains how many bytes of - * objPtr have been used to hold data. On - * output, filled with how many bytes are now - * being used. */ + int *offsetPtr; /* On input, contains how many bytes of objPtr + * have been used to hold data. On output, + * filled with how many bytes are now being + * used. */ { int toRead, srcLen, offset, length, srcRead, dstWrote; ChannelBuffer *bufPtr; @@ -4615,7 +4572,7 @@ ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) offset = *offsetPtr; - bufPtr = statePtr->inQueueHead; + bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; @@ -4627,9 +4584,9 @@ ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) dst = (char *) Tcl_GetByteArrayFromObj(objPtr, &length); if (toRead > length - offset - 1) { /* - * Double the existing size of the object or make enough room to - * hold all the characters we may get from the source buffer, - * whichever is larger. + * Double the existing size of the object or make enough room to hold + * all the characters we may get from the source buffer, whichever is + * larger. */ length = offset * 2; @@ -4670,21 +4627,19 @@ ReadBytes(statePtr, objPtr, bytesToRead, offsetPtr) * * ReadChars -- * - * Reads from the channel until the requested number of UTF-8 - * characters have been seen, EOF is seen, or the channel would - * block. Raw bytes from the channel are converted to UTF-8 - * and stored in objPtr. EOL and EOF translation is done. + * Reads from the channel until the requested number of UTF-8 characters + * have been seen, EOF is seen, or the channel would block. Raw bytes + * from the channel are converted to UTF-8 and stored in objPtr. EOL and + * EOF translation is done. * - * 'charsToRead' can safely be a very large number because - * space is only allocated to hold data read from the channel - * as needed. + * 'charsToRead' can safely be a very large number because space is only + * allocated to hold data read from the channel as needed. * * Results: - * The return value is the number of characters appended to - * the object, *offsetPtr is filled with the number of bytes that - * were appended, and *factorPtr is filled with the expansion - * factor used to guess how many bytes of UTF-8 to allocate to - * hold N source bytes. + * The return value is the number of characters appended to the object, + * *offsetPtr is filled with the number of bytes that were appended, and + * *factorPtr is filled with the expansion factor used to guess how many + * bytes of UTF-8 to allocate to hold N source bytes. * * Side effects: * None. @@ -4699,18 +4654,18 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * objPtr->length is how much space has been * allocated to hold data, not how many bytes * of data have been stored in the object. */ - int charsToRead; /* Maximum number of characters to store, - * or -1 to get all available characters. + int charsToRead; /* Maximum number of characters to store, or + * -1 to get all available characters. * Characters are obtained from the first * buffer in the queue -- even if this number * is larger than the number of characters * available in the first buffer, only the * characters from the first buffer are * returned. */ - int *offsetPtr; /* On input, contains how many bytes of - * objPtr have been used to hold data. On - * output, filled with how many bytes are now - * being used. */ + int *offsetPtr; /* On input, contains how many bytes of objPtr + * have been used to hold data. On output, + * filled with how many bytes are now being + * used. */ int *factorPtr; /* On input, contains a guess of how many * bytes need to be allocated to hold the * result of converting N source bytes to @@ -4726,7 +4681,7 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) factor = *factorPtr; offset = *offsetPtr; - bufPtr = statePtr->inQueueHead; + bufPtr = statePtr->inQueueHead; src = bufPtr->buf + bufPtr->nextRemoved; srcLen = bufPtr->nextAdded - bufPtr->nextRemoved; @@ -4736,10 +4691,9 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) } /* - * 'factor' is how much we guess that the bytes in the source buffer - * will expand when converted to UTF-8 chars. This guess comes from - * analyzing how many characters were produced by the previous - * pass. + * 'factor' is how much we guess that the bytes in the source buffer will + * expand when converted to UTF-8 chars. This guess comes from analyzing + * how many characters were produced by the previous pass. */ dstNeeded = toRead * factor / UTF_EXPANSION_FACTOR; @@ -4747,9 +4701,9 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) if (dstNeeded > spaceLeft) { /* - * Double the existing size of the object or make enough room to - * hold all the characters we want from the source buffer, - * whichever is larger. + * Double the existing size of the object or make enough room to hold + * all the characters we want from the source buffer, whichever is + * larger. */ length = offset * 2; @@ -4762,9 +4716,9 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) } if (toRead == srcLen) { /* - * Want to convert the whole buffer in one pass. If we have - * enough space, convert it using all available space in object - * rather than using the factor. + * Want to convert the whole buffer in one pass. If we have enough + * space, convert it using all available space in object rather than + * using the factor. */ dstNeeded = spaceLeft; @@ -4804,9 +4758,9 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) dstNeeded + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); if (srcRead == 0) { /* - * Not enough bytes in src buffer to make a complete char. Copy - * the bytes to the next buffer to make a new contiguous string, - * then tell the caller to fill the buffer with more bytes. + * Not enough bytes in src buffer to make a complete char. Copy the + * bytes to the next buffer to make a new contiguous string, then tell + * the caller to fill the buffer with more bytes. */ ChannelBuffer *nextPtr; @@ -4821,11 +4775,10 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * * SF #478856. * - * The exception to this is if the input buffer was - * completely empty before we tried to convert its - * contents. Nothing in, nothing out, and no incomplete - * character data. The conversion before the current one - * was complete. + * The exception to this is if the input buffer was completely + * empty before we tried to convert its contents. Nothing in, + * nothing out, and no incomplete character data. The + * conversion before the current one was complete. */ statePtr->flags |= CHANNEL_NEED_MORE_DATA; @@ -4843,10 +4796,10 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) dstRead = dstWrote; if (TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead) != 0) { /* - * Hit EOF char. How many bytes of src correspond to where the - * EOF was located in dst? Run the conversion again with an - * output buffer just big enough to hold the data so we can - * get the correct value for srcRead. + * Hit EOF char. How many bytes of src correspond to where the EOF was + * located in dst? Run the conversion again with an output buffer just + * big enough to hold the data so we can get the correct value for + * srcRead. */ if (dstWrote == 0) { @@ -4857,12 +4810,12 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) statePtr->inputEncodingFlags, &statePtr->inputEncodingState, dst, dstRead + TCL_UTF_MAX, &srcRead, &dstWrote, &numChars); TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); - } + } /* - * The number of characters that we got may be less than the number - * that we started with because "\r\n" sequences may have been - * turned into just '\n' in dst. + * The number of characters that we got may be less than the number that + * we started with because "\r\n" sequences may have been turned into just + * '\n' in dst. */ numChars -= (dstRead - dstWrote); @@ -4898,12 +4851,12 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) * * TranslateInputEOL -- * - * Perform input EOL and EOF translation on the source buffer, - * leaving the translated result in the destination buffer. + * Perform input EOL and EOF translation on the source buffer, leaving + * the translated result in the destination buffer. * * Results: * The return value is 1 if the EOF character was found when copying - * bytes to the destination buffer, 0 otherwise. + * bytes to the destination buffer, 0 otherwise. * * Side effects: * None. @@ -4913,19 +4866,19 @@ ReadChars(statePtr, objPtr, charsToRead, offsetPtr, factorPtr) static int TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) - ChannelState *statePtr; /* Channel being read, for EOL translation - * and EOF character. */ - char *dstStart; /* Output buffer filled with chars by - * applying appropriate EOL translation to - * source characters. */ + ChannelState *statePtr; /* Channel being read, for EOL translation and + * EOF character. */ + char *dstStart; /* Output buffer filled with chars by applying + * appropriate EOL translation to source + * characters. */ CONST char *srcStart; /* Source characters. */ int *dstLenPtr; /* On entry, the maximum length of output - * buffer in bytes; must be <= *srcLenPtr. On + * buffer in bytes; must be <= *srcLenPtr. On * exit, the number of bytes actually used in * output buffer. */ - int *srcLenPtr; /* On entry, the length of source buffer. - * On exit, the number of bytes read from - * the source buffer. */ + int *srcLenPtr; /* On entry, the length of source buffer. On + * exit, the number of bytes read from the + * source buffer. */ { int dstLen, srcLen, inEofChar; CONST char *eof; @@ -4936,10 +4889,10 @@ TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) inEofChar = statePtr->inEofChar; if (inEofChar != '\0') { /* - * Find EOF in translated buffer then compress out the EOL. The - * source buffer may be much longer than the destination buffer -- - * we only want to return EOF if the EOF has been copied to the - * destination buffer. + * Find EOF in translated buffer then compress out the EOL. The source + * buffer may be much longer than the destination buffer - we only + * want to return EOF if the EOF has been copied to the destination + * buffer. */ CONST char *src, *srcMax; @@ -4958,101 +4911,99 @@ TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) } } switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - if (dstStart != srcStart) { - memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); - } - srcLen = dstLen; - break; - } - case TCL_TRANSLATE_CR: { - char *dst, *dstEnd; - - if (dstStart != srcStart) { - memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + case TCL_TRANSLATE_LF: + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + srcLen = dstLen; + break; + case TCL_TRANSLATE_CR: { + char *dst, *dstEnd; + + if (dstStart != srcStart) { + memcpy((VOID *) dstStart, (VOID *) srcStart, (size_t) dstLen); + } + dstEnd = dstStart + dstLen; + for (dst = dstStart; dst < dstEnd; dst++) { + if (*dst == '\r') { + *dst = '\n'; } - dstEnd = dstStart + dstLen; - for (dst = dstStart; dst < dstEnd; dst++) { - if (*dst == '\r') { - *dst = '\n'; - } - } - srcLen = dstLen; - break; } - case TCL_TRANSLATE_CRLF: { - char *dst; - CONST char *src, *srcEnd, *srcMax; + srcLen = dstLen; + break; + } + case TCL_TRANSLATE_CRLF: { + char *dst; + CONST char *src, *srcEnd, *srcMax; - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - statePtr->flags |= INPUT_NEED_NL; - } else if (*src == '\n') { - *dst++ = *src++; - } else { - *dst++ = '\r'; - } - } else { + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + statePtr->flags |= INPUT_NEED_NL; + } else if (*src == '\n') { *dst++ = *src++; + } else { + *dst++ = '\r'; } + } else { + *dst++ = *src++; } - srcLen = src - srcStart; - dstLen = dst - dstStart; - break; } - case TCL_TRANSLATE_AUTO: { - char *dst; - CONST char *src, *srcEnd, *srcMax; + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + case TCL_TRANSLATE_AUTO: { + char *dst; + CONST char *src, *srcEnd, *srcMax; - dst = dstStart; - src = srcStart; - srcEnd = srcStart + dstLen; - srcMax = srcStart + *srcLenPtr; + dst = dstStart; + src = srcStart; + srcEnd = srcStart + dstLen; + srcMax = srcStart + *srcLenPtr; - if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { - if (*src == '\n') { - src++; - } - statePtr->flags &= ~INPUT_SAW_CR; + if ((statePtr->flags & INPUT_SAW_CR) && (src < srcMax)) { + if (*src == '\n') { + src++; } - for ( ; src < srcEnd; ) { - if (*src == '\r') { - src++; - if (src >= srcMax) { - statePtr->flags |= INPUT_SAW_CR; - } else if (*src == '\n') { - if (srcEnd < srcMax) { - srcEnd++; - } - src++; + statePtr->flags &= ~INPUT_SAW_CR; + } + for ( ; src < srcEnd; ) { + if (*src == '\r') { + src++; + if (src >= srcMax) { + statePtr->flags |= INPUT_SAW_CR; + } else if (*src == '\n') { + if (srcEnd < srcMax) { + srcEnd++; } - *dst++ = '\n'; - } else { - *dst++ = *src++; + src++; } + *dst++ = '\n'; + } else { + *dst++ = *src++; } - srcLen = src - srcStart; - dstLen = dst - dstStart; - break; - } - default: { /* lint. */ - return 0; } + srcLen = src - srcStart; + dstLen = dst - dstStart; + break; + } + default: + return 0; } *dstLenPtr = dstLen; if ((eof != NULL) && (srcStart + srcLen >= eof)) { /* - * EOF character was seen in EOL translated range. Leave current - * file position pointing at the EOF character, but don't store the - * EOF character in the output string. + * EOF character was seen in EOL translated range. Leave current file + * position pointing at the EOF character, but don't store the EOF + * character in the output string. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); @@ -5070,8 +5021,8 @@ TranslateInputEOL(statePtr, dstStart, srcStart, dstLenPtr, srcLenPtr) * * Tcl_Ungets -- * - * Causes the supplied string to be added to the input queue of - * the channel, at either the head or tail of the queue. + * Causes the supplied string to be added to the input queue of the + * channel, at either the head or tail of the queue. * * Results: * The number of bytes stored in the channel, or -1 on error. @@ -5088,7 +5039,7 @@ Tcl_Ungets(chan, str, len, atEnd) CONST char *str; /* The input itself. */ int len; /* The length of the input. */ int atEnd; /* If non-zero, add at end of queue; otherwise - * add at head of queue. */ + * add at head of queue. */ { Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of actual channel. */ @@ -5116,11 +5067,10 @@ Tcl_Ungets(chan, str, len, atEnd) statePtr->flags = flags; /* - * If we have encountered a sticky EOF, just punt without storing. - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Otherwise, clear the EOF flags, and - * clear the BLOCKED bit. We want to discover these conditions anew - * in each operation. + * If we have encountered a sticky EOF, just punt without storing (sticky + * EOF is set if we have seen the input eofChar, to prevent reading beyond + * the eofChar). Otherwise, clear the EOF flags, and clear the BLOCKED + * bit. We want to discover these conditions anew in each operation. */ if (statePtr->flags & CHANNEL_STICKY_EOF) { @@ -5146,12 +5096,12 @@ Tcl_Ungets(chan, str, len, atEnd) statePtr->inQueueHead = bufPtr; } - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return len; } @@ -5213,8 +5163,8 @@ Tcl_Flush(chan) * * DiscardInputQueued -- * - * Discards any input read from the channel but not yet consumed - * by Tcl reading commands. + * Discards any input read from the channel but not yet consumed by Tcl + * reading commands. * * Results: * None. @@ -5228,8 +5178,8 @@ Tcl_Flush(chan) static void DiscardInputQueued(statePtr, discardSavedBuffers) - ChannelState *statePtr; /* Channel on which to discard - * the queued input. */ + ChannelState *statePtr; /* Channel on which to discard the queued + * input. */ int discardSavedBuffers; /* If non-zero, discard all buffers including * last one. */ { @@ -5261,11 +5211,11 @@ DiscardInputQueued(statePtr, discardSavedBuffers) * * GetInput -- * - * Reads input data from a device into a channel buffer. + * Reads input data from a device into a channel buffer. * * Results: * The return value is the Posix error code if an error occurred while - * reading from the file, or 0 otherwise. + * reading from the file, or 0 otherwise. * * Side effects: * Reads from the underlying device. @@ -5295,13 +5245,13 @@ GetInput(chanPtr) } /* - * First check for more buffers in the pushback area of the - * topmost channel in the stack and use them. They can be the - * result of a transformation which went away without reading all - * the information placed in the area when it was stacked. + * First check for more buffers in the pushback area of the topmost + * channel in the stack and use them. They can be the result of a + * transformation which went away without reading all the information + * placed in the area when it was stacked. * - * Two possibilities for the state: No buffers in it, or a single - * empty buffer. In the latter case we can recycle it now. + * Two possibilities for the state: No buffers in it, or a single empty + * buffer. In the latter case we can recycle it now. */ if (chanPtr->inQueueHead != (ChannelBuffer *) NULL) { @@ -5318,14 +5268,14 @@ GetInput(chanPtr) } /* - * Nothing in the pushback area, fall back to the usual handling - * (driver, etc.) + * Nothing in the pushback area, fall back to the usual handling (driver, + * etc.) */ /* - * See if we can fill an existing buffer. If we can, read only - * as much as will fit in it. Otherwise allocate a new buffer, - * add it to the input queue and attempt to fill it to the max. + * See if we can fill an existing buffer. If we can, read only as much as + * will fit in it. Otherwise allocate a new buffer, add it to the input + * queue and attempt to fill it to the max. */ bufPtr = statePtr->inQueueTail; @@ -5338,8 +5288,8 @@ GetInput(chanPtr) /* * Check the actual buffersize against the requested * buffersize. Buffers which are smaller than requested are - * squashed. This is done to honor dynamic changes of the - * buffersize made by the user. + * squashed. This is done to honor dynamic changes of the buffersize + * made by the user. */ if ((bufPtr != NULL) @@ -5353,17 +5303,18 @@ GetInput(chanPtr) } bufPtr->nextPtr = (ChannelBuffer *) NULL; - /* SF #427196: Use the actual size of the buffer to determine - * the number of bytes to read from the channel and not the - * size for new buffers. They can be different if the - * buffersize was changed between reads. + /* + * SF #427196: Use the actual size of the buffer to determine the + * number of bytes to read from the channel and not the size for new + * buffers. They can be different if the buffersize was changed + * between reads. * - * Note: This affects performance negatively if the buffersize - * was extended but this small buffer is reused for all - * subsequent reads. The system never uses buffers with the - * requested bigger size in that case. An adjunct patch could - * try and delete all unused buffers it encounters and which - * are smaller than the formally requested buffersize. + * Note: This affects performance negatively if the buffersize was + * extended but this small buffer is reused for all subsequent reads. + * The system never uses buffers with the requested bigger size in + * that case. An adjunct patch could try and delete all unused buffers + * it encounters and which are smaller than the formally requested + * buffersize. */ toRead = bufPtr->bufLength - bufPtr->nextAdded; @@ -5387,10 +5338,10 @@ GetInput(chanPtr) #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING /* - * [SF Tcl Bug 943274]. Better emulation of non-blocking channels - * for channels without BlockModeProc, by keeping track of true - * fileevents generated by the OS == Data waiting and reading if - * and only if we are sure to have data. + * [SF Tcl Bug 943274]. Better emulation of non-blocking channels for + * channels without BlockModeProc, by keeping track of true fileevents + * generated by the OS == Data waiting and reading if and only if we are + * sure to have data. */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && @@ -5404,8 +5355,10 @@ GetInput(chanPtr) result = EWOULDBLOCK; } else { #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ + nread = (chanPtr->typePtr->inputProc)(chanPtr->instanceData, bufPtr->buf + bufPtr->nextAdded, toRead, &result); + #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING } #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ @@ -5414,10 +5367,10 @@ GetInput(chanPtr) bufPtr->nextAdded += nread; /* - * If we get a short read, signal up that we may be BLOCKED. We - * should avoid calling the driver because on some platforms we - * will block in the low level reading code even though the - * channel is set into nonblocking mode. + * If we get a short read, signal up that we may be BLOCKED. We should + * avoid calling the driver because on some platforms we will block in + * the low level reading code even though the channel is set into + * nonblocking mode. */ if (nread < toRead) { @@ -5427,8 +5380,8 @@ GetInput(chanPtr) #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING if (nread <= toRead) { /* - * [SF Tcl Bug 943274] We have read the available data, - * clear flag. + * [SF Tcl Bug 943274] We have read the available data, clear + * flag. */ statePtr->flags &= ~CHANNEL_HAS_MORE_DATA; @@ -5454,12 +5407,12 @@ GetInput(chanPtr) * * Tcl_Seek -- * - * Implements seeking on Tcl Channels. This is a public function - * so that other C facilities may be implemented on top of it. + * Implements seeking on Tcl Channels. This is a public function so that + * other C facilities may be implemented on top of it. * * Results: - * The new access point or -1 on error. If error, use Tcl_GetErrno() - * to retrieve the POSIX error code for the error that occurred. + * The new access point or -1 on error. If error, use Tcl_GetErrno() to + * retrieve the POSIX error code for the error that occurred. * * Side effects: * May flush output on the channel. May discard queued input. @@ -5479,19 +5432,19 @@ Tcl_Seek(chan, offset, mode) /* # bytes held in buffers. */ int result; /* Of device driver operations. */ Tcl_WideInt curPos; /* Position on the device. */ - int wasAsync; /* Was the channel nonblocking before the - * seek operation? If so, must restore to - * nonblocking mode after the seek. */ + int wasAsync; /* Was the channel nonblocking before the seek + * operation? If so, must restore to + * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { return Tcl_LongAsWide(-1); } /* - * Disallow seek on dead channels -- channels that have been closed but - * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * Disallow seek on dead channels - channels that have been closed but not + * yet been deallocated. Such channels can be found if the exit handler + * for channel cleanup has run but the channel is still registered in an + * interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { @@ -5515,8 +5468,8 @@ Tcl_Seek(chan, offset, mode) } /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. + * Compute how much input and output is buffered. If both input and output + * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); @@ -5537,25 +5490,25 @@ Tcl_Seek(chan, offset, mode) } /* - * Discard any queued input - this input should not be read after - * the seek. + * Discard any queued input - this input should not be read after the + * seek. */ DiscardInputQueued(statePtr, 0); /* - * Reset EOF and BLOCKED flags. We invalidate them by moving the - * access point. Also clear CR related flags. + * Reset EOF and BLOCKED flags. We invalidate them by moving the access + * point. Also clear CR related flags. */ statePtr->flags &= ~(CHANNEL_EOF | CHANNEL_STICKY_EOF | CHANNEL_BLOCKED | INPUT_SAW_CR); /* - * If the channel is in asynchronous output mode, switch it back - * to synchronous mode and cancel any async flush that may be - * scheduled. After the flush, the channel will be put back into - * asynchronous output mode. + * If the channel is in asynchronous output mode, switch it back to + * synchronous mode and cancel any async flush that may be scheduled. + * After the flush, the channel will be put back into asynchronous output + * mode. */ wasAsync = 0; @@ -5572,8 +5525,8 @@ Tcl_Seek(chan, offset, mode) } /* - * If there is data buffered in statePtr->curOutPtr then mark - * the channel as ready to flush before invoking FlushChannel. + * If there is data buffered in statePtr->curOutPtr then mark the channel + * as ready to flush before invoking FlushChannel. */ if ((statePtr->curOutPtr != (ChannelBuffer *) NULL) && @@ -5583,11 +5536,11 @@ Tcl_Seek(chan, offset, mode) } /* - * If the flush fails we cannot recover the original position. In - * that case the seek is not attempted because we do not know where - * the access position is - instead we return the error. FlushChannel - * has already called Tcl_SetErrno() to report the error upwards. - * If the flush succeeds we do the seek also. + * If the flush fails we cannot recover the original position. In that + * case the seek is not attempted because we do not know where the access + * position is - instead we return the error. FlushChannel has already + * called Tcl_SetErrno() to report the error upwards. If the flush + * succeeds we do the seek also. */ if (FlushChannel(NULL, chanPtr, 0) != 0) { @@ -5596,8 +5549,8 @@ Tcl_Seek(chan, offset, mode) /* * Now seek to the new position in the channel as requested by the - * caller. Note that we prefer the wideSeekProc if that is - * available and non-NULL... + * caller. Note that we prefer the wideSeekProc if that is available + * and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && @@ -5621,8 +5574,8 @@ Tcl_Seek(chan, offset, mode) /* * Restore to nonblocking mode if that was the previous behavior. * - * NOTE: Even if there was an async flush active we do not restore - * it now because we already flushed all the queued output, above. + * NOTE: Even if there was an async flush active we do not restore it now + * because we already flushed all the queued output, above. */ if (wasAsync) { @@ -5641,13 +5594,13 @@ Tcl_Seek(chan, offset, mode) * * Tcl_Tell -- * - * Returns the position of the next character to be read/written on - * this channel. + * Returns the position of the next character to be read/written on this + * channel. * * Results: - * A nonnegative integer on success, -1 on failure. If failed, - * use Tcl_GetErrno() to retrieve the POSIX error code for the - * error that occurred. + * A nonnegative integer on success, -1 on failure. If failed, use + * Tcl_GetErrno() to retrieve the POSIX error code for the error that + * occurred. * * Side effects: * None. @@ -5672,8 +5625,8 @@ Tcl_Tell(chan) /* * Disallow tell on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { @@ -5697,8 +5650,8 @@ Tcl_Tell(chan) } /* - * Compute how much input and output is buffered. If both input and - * output is buffered, cannot compute the current position. + * Compute how much input and output is buffered. If both input and output + * is buffered, cannot compute the current position. */ inputBuffered = Tcl_InputBuffered(chan); @@ -5710,9 +5663,9 @@ Tcl_Tell(chan) } /* - * Get the current position in the device and compute the position - * where the next character will be read or written. Note that we - * prefer the wideSeekProc if that is available and non-NULL... + * Get the current position in the device and compute the position where + * the next character will be read or written. Note that we prefer the + * wideSeekProc if that is available and non-NULL... */ if (HaveVersion(chanPtr->typePtr, TCL_CHANNEL_VERSION_3) && @@ -5738,9 +5691,9 @@ Tcl_Tell(chan) * * Tcl_SeekOld, Tcl_TellOld -- * - * Backward-compatability versions of the seek/tell interface that - * do not support 64-bit offsets. This interface is not documented - * or expected to be supported indefinitely. + * Backward-compatability versions of the seek/tell interface that do not + * support 64-bit offsets. This interface is not documented or expected + * to be supported indefinitely. * * Results: * As for Tcl_Seek and Tcl_Tell respectively, except truncated to @@ -5783,13 +5736,12 @@ Tcl_TellOld(chan) * Truncate a channel to the given length. * * Results: - * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is - * not supported by the type of channel, or the underlying OS - * operation failed in some way). + * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not + * supported by the type of channel, or the underlying OS operation + * failed in some way). * * Side effects: - * Seeks the channel to the current location. Sets errno on OS - * error. + * Seeks the channel to the current location. Sets errno on OS error. * *--------------------------------------------------------------------------- */ @@ -5815,17 +5767,16 @@ Tcl_TruncateChannel(chan, length) if (!(chanPtr->state->flags & TCL_WRITABLE)) { /* - * We require that the file was opened of writing. Do that - * check now so that we only flush if we think we're going to - * succeed. + * We require that the file was opened of writing. Do that check now + * so that we only flush if we think we're going to succeed. */ Tcl_SetErrno(EINVAL); return TCL_ERROR; } /* - * Seek first to force a total flush of all pending buffers and - * ditch any pre-read input data. + * Seek first to force a total flush of all pending buffers and ditch any + * pre-read input data. */ if (Tcl_Seek(chan, 0, SEEK_CUR) == Tcl_LongAsWide(-1)) { @@ -5833,9 +5784,8 @@ Tcl_TruncateChannel(chan, length) } /* - * We're all flushed to disk now and we also don't have any - * unfortunate input baggage around either; can truncate with - * impunity. + * We're all flushed to disk now and we also don't have any unfortunate + * input baggage around either; can truncate with impunity. */ result = truncateProc(chanPtr->instanceData, length); @@ -5851,12 +5801,12 @@ Tcl_TruncateChannel(chan, length) * * CheckChannelErrors -- * - * See if the channel is in an ready state and can perform the - * desired operation. + * See if the channel is in an ready state and can perform the desired + * operation. * * Results: - * The return value is 0 if the channel is OK, otherwise the - * return value is -1 and errno is set to indicate the error. + * The return value is 0 if the channel is OK, otherwise the return value + * is -1 and errno is set to indicate the error. * * Side effects: * May clear the EOF and/or BLOCKED bits if reading from channel. @@ -5885,8 +5835,8 @@ CheckChannelErrors(statePtr, flags) } /* - * Only the raw read and write operations are allowed during close - * in order to drain data from stacked channels. + * Only the raw read and write operations are allowed during close in + * order to drain data from stacked channels. */ if ((statePtr->flags & CHANNEL_CLOSED) && @@ -5919,10 +5869,10 @@ CheckChannelErrors(statePtr, flags) if (direction == TCL_READABLE) { /* - * If we have not encountered a sticky EOF, clear the EOF bit - * (sticky EOF is set if we have seen the input eofChar, to prevent - * reading beyond the eofChar). Also, always clear the BLOCKED bit. - * We want to discover these conditions anew in each operation. + * If we have not encountered a sticky EOF, clear the EOF bit (sticky + * EOF is set if we have seen the input eofChar, to prevent reading + * beyond the eofChar). Also, always clear the BLOCKED bit. We want to + * discover these conditions anew in each operation. */ if ((statePtr->flags & CHANNEL_STICKY_EOF) == 0) { @@ -5993,12 +5943,12 @@ Tcl_InputBlocked(chan) * * Tcl_InputBuffered -- * - * Returns the number of bytes of input currently buffered in the - * common internal buffer of a channel. + * Returns the number of bytes of input currently buffered in the common + * internal buffer of a channel. * * Results: - * The number of input bytes buffered, or zero if the channel is not - * open for reading. + * The number of input bytes buffered, or zero if the channel is not open + * for reading. * * Side effects: * None. @@ -6039,12 +5989,12 @@ Tcl_InputBuffered(chan) * * Tcl_OutputBuffered -- * - * Returns the number of bytes of output currently buffered in the - * common internal buffer of a channel. + * Returns the number of bytes of output currently buffered in the common + * internal buffer of a channel. * * Results: - * The number of output bytes buffered, or zero if the channel is not - * open for writing. + * The number of output bytes buffered, or zero if the channel is not open + * for writing. * * Side effects: * None. @@ -6084,8 +6034,8 @@ Tcl_OutputBuffered(chan) * internal buffer (push back area) of a channel. * * Results: - * The number of input bytes buffered, or zero if the channel is not - * open for reading. + * The number of input bytes buffered, or zero if the channel is not open + * for reading. * * Side effects: * None. @@ -6116,8 +6066,8 @@ Tcl_ChannelBuffered(chan) * * Tcl_SetChannelBufferSize -- * - * Sets the size of buffers to allocate to store input or output - * in the channel. The size must be between 1 byte and 1 MByte. + * Sets the size of buffers to allocate to store input or output in the + * channel. The size must be between 1 byte and 1 MByte. * * Results: * None. @@ -6130,15 +6080,15 @@ Tcl_ChannelBuffered(chan) void Tcl_SetChannelBufferSize(chan, sz) - Tcl_Channel chan; /* The channel whose buffer size - * to set. */ + Tcl_Channel chan; /* The channel whose buffer size to + * set. */ int sz; /* The size to set. */ { ChannelState *statePtr; /* State of real channel structure. */ /* - * If the buffer size is smaller than 1 byte or larger than one MByte, - * do not accept the requested size and leave the current buffer size. + * If the buffer size is smaller than 1 byte or larger than one MByte, do + * not accept the requested size and leave the current buffer size. */ if (sz < 1) { @@ -6157,7 +6107,7 @@ Tcl_SetChannelBufferSize(chan, sz) } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { statePtr->outputStage = (char *) - ckalloc((unsigned) (statePtr->bufSize + 2)); + ckalloc((unsigned) (statePtr->bufSize + 2)); } } @@ -6193,43 +6143,44 @@ Tcl_GetChannelBufferSize(chan) * * Tcl_BadChannelOption -- * - * This procedure generates a "bad option" error message in an - * (optional) interpreter. It is used by channel drivers when - * a invalid Set/Get option is requested. Its purpose is to concatenate - * the generic options list to the specific ones and factorize - * the generic options error message string. + * This procedure generates a "bad option" error message in an (optional) + * interpreter. It is used by channel drivers when a invalid Set/Get + * option is requested. Its purpose is to concatenate the generic options + * list to the specific ones and factorize the generic options error + * message string. * * Results: * TCL_ERROR. * * Side effects: - * An error message is generated in interp's result object to - * indicate that a command was invoked with the a bad option - * The message has the form - * bad option "blah": should be one of + + * An error message is generated in interp's result object to indicate + * that a command was invoked with the a bad option. The message has the + * form: + * bad option "blah": should be one of * <...generic options...>+<...specific options...> - * "blah" is the optionName argument and "" - * is a space separated list of specific option words. - * The function takes good care of inserting minus signs before - * each option, commas after, and an "or" before the last option. + * "blah" is the optionName argument and "" is a space + * separated list of specific option words. The function takes good care + * of inserting minus signs before each option, commas after, and an "or" + * before the last option. * *---------------------------------------------------------------------- */ int Tcl_BadChannelOption(interp, optionName, optionList) - Tcl_Interp *interp; /* Current interpreter. (can be NULL)*/ + Tcl_Interp *interp; /* Current interpreter (can be NULL).*/ CONST char *optionName; /* 'bad option' name */ - CONST char *optionList; /* Specific options list to append - * to the standard generic options. - * can be NULL for generic options + CONST char *optionList; /* Specific options list to append to + * the standard generic options. Can + * be NULL for generic options * only. */ { - if (interp) { - CONST char *genericopt = - "blocking buffering buffersize encoding eofchar translation"; + if (interp != NULL) { + CONST char *genericopt = + "blocking buffering buffersize encoding eofchar translation"; CONST char **argv; - int argc, i; + int argc, i; Tcl_DString ds; Tcl_DStringInit(&ds); @@ -6238,12 +6189,12 @@ Tcl_BadChannelOption(interp, optionName, optionList) Tcl_DStringAppend(&ds, " ", 1); Tcl_DStringAppend(&ds, optionList, -1); } - if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), + if (Tcl_SplitList(interp, Tcl_DStringValue(&ds), &argc, &argv) != TCL_OK) { Tcl_Panic("malformed option list in channel driver"); } Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad option \"", optionName, + Tcl_AppendResult(interp, "bad option \"", optionName, "\": should be one of ", (char *) NULL); argc--; for (i = 0; i < argc; i++) { @@ -6262,14 +6213,14 @@ Tcl_BadChannelOption(interp, optionName, optionList) * * Tcl_GetChannelOption -- * - * Gets a mode associated with an IO channel. If the optionName arg - * is non NULL, retrieves the value of that option. If the optionName - * arg is NULL, retrieves a list of alternating option names and - * values for the given channel. + * Gets a mode associated with an IO channel. If the optionName arg is + * non NULL, retrieves the value of that option. If the optionName arg is + * NULL, retrieves a list of alternating option names and values for the + * given channel. * * Results: - * A standard Tcl result. Also sets the supplied DString to the - * string value of the option(s) returned. + * A standard Tcl result. Also sets the supplied DString to the string + * value of the option(s) returned. * * Side effects: * None. @@ -6293,8 +6244,8 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(interp, statePtr)) { @@ -6322,8 +6273,8 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } /* - * If the optionName is NULL it means that we want a list of all - * options and values. + * If the optionName is NULL it means that we want a list of all options + * and values. */ if (optionName == (char *) NULL) { @@ -6477,15 +6428,15 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) } if (chanPtr->typePtr->getOptionProc != (Tcl_DriverGetOptionProc *) NULL) { /* - * let the driver specific handle additional options - * and result code and message. + * Let the driver specific handle additional options and result code + * and message. */ return (chanPtr->typePtr->getOptionProc) (chanPtr->instanceData, interp, optionName, dsPtr); } else { /* - * no driver specific options case. + * No driver specific options case. */ if (len == 0) { @@ -6503,8 +6454,8 @@ Tcl_GetChannelOption(interp, chan, optionName, dsPtr) * Sets an option on a channel. * * Results: - * A standard Tcl result. On error, sets interp's result object - * if interp is not NULL. + * A standard Tcl result. On error, sets interp's result object if + * interp is not NULL. * * Side effects: * May modify an option on a device. @@ -6540,8 +6491,8 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) /* * Disallow options on dead channels -- channels that have been closed but * not yet been deallocated. Such channels can be found if the exit - * handler for channel cleanup has run but the channel is still - * registered in an interpreter. + * handler for channel cleanup has run but the channel is still registered + * in an interpreter. */ if (CheckForDeadChannel(NULL, statePtr)) { @@ -6665,9 +6616,9 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } /* - * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing - * the character which signals eof can transform a current eof - * condition into a 'go ahead'. Ditto for blocked. + * [SF Tcl Bug 930851] Reset EOF and BLOCKED flags. Changing the + * character which signals eof can transform a current eof condition + * into a 'go ahead'. Ditto for blocked. */ statePtr->flags &= @@ -6707,7 +6658,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(readMode, "binary") == 0) { translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; - Tcl_FreeEncoding(statePtr->encoding); + Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; @@ -6729,9 +6680,9 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } /* - * Reset the EOL flags since we need to look at any buffered - * data to see if the new translation mode allows us to - * complete the line. + * Reset the EOL flags since we need to look at any buffered data + * to see if the new translation mode allows us to complete the + * line. */ if (translation != statePtr->inputTranslation) { @@ -6746,10 +6697,9 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) /* Do nothing. */ } else if (strcmp(writeMode, "auto") == 0) { /* - * This is a hack to get TCP sockets to produce output - * in CRLF mode if they are being set into AUTO mode. - * A better solution for achieving this effect will be - * coded later. + * This is a hack to get TCP sockets to produce output in CRLF + * mode if they are being set into AUTO mode. A better + * solution for achieving this effect will be coded later. */ if (strcmp(Tcl_ChannelName(chanPtr->typePtr), "tcp") == 0) { @@ -6760,7 +6710,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) } else if (strcmp(writeMode, "binary") == 0) { statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; - Tcl_FreeEncoding(statePtr->encoding); + Tcl_FreeEncoding(statePtr->encoding); statePtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; @@ -6781,7 +6731,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) return TCL_ERROR; } } - ckfree((char *) argv); + ckfree((char *) argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return (*chanPtr->typePtr->setOptionProc)(chanPtr->instanceData, @@ -6817,7 +6767,7 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) statePtr->outputStage = NULL; } if ((statePtr->encoding != NULL) && (statePtr->flags & TCL_WRITABLE)) { - statePtr->outputStage = (char *) + statePtr->outputStage = (char *) ckalloc((unsigned) (statePtr->bufSize + 2)); } return TCL_OK; @@ -6828,11 +6778,10 @@ Tcl_SetChannelOption(interp, chan, optionName, newValue) * * CleanupChannelHandlers -- * - * Removes channel handlers that refer to the supplied interpreter, - * so that if the actual channel is not closed now, these handlers - * will not run on subsequent events on the channel. This would be - * erroneous, because the interpreter no longer has a reference to - * this channel. + * Removes channel handlers that refer to the supplied interpreter, so + * that if the actual channel is not closed now, these handlers will not + * run on subsequent events on the channel. This would be erroneous, + * because the interpreter no longer has a reference to this channel. * * Results: * None. @@ -6852,8 +6801,8 @@ CleanupChannelHandlers(interp, chanPtr) EventScriptRecord *sPtr, *prevPtr, *nextPtr; /* - * Remove fileevent records on this channel that refer to the - * given interpreter. + * Remove fileevent records on this channel that refer to the given + * interpreter. */ for (sPtr = statePtr->scriptRecordPtr, @@ -6884,10 +6833,9 @@ CleanupChannelHandlers(interp, chanPtr) * * Tcl_NotifyChannel -- * - * This procedure is called by a channel driver when a driver - * detects an event on a channel. This procedure is responsible - * for actually handling the event by invoking any channel - * handler callbacks. + * This procedure is called by a channel driver when a driver detects an + * event on a channel. This procedure is responsible for actually + * handling the event by invoking any channel handler callbacks. * * Results: * None. @@ -6914,10 +6862,10 @@ Tcl_NotifyChannel(channel, mask) Tcl_ChannelType *upTypePtr; #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* [SF Tcl Bug 943274] - * For a non-blocking channel without blockmodeproc we keep track - * of actual input coming from the OS so that we can do a credible - * imitation of non-blocking behaviour. + /* + * [SF Tcl Bug 943274] For a non-blocking channel without blockmodeproc we + * keep track of actual input coming from the OS so that we can do a + * credible imitation of non-blocking behaviour. */ if ((mask & TCL_READABLE) && @@ -6930,15 +6878,15 @@ Tcl_NotifyChannel(channel, mask) #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ /* - * In contrast to the other API functions this procedure walks towards - * the top of a stack and not down from it. + * In contrast to the other API functions this procedure walks towards the + * top of a stack and not down from it. * * The channel calling this procedure is the one who generated the event, - * and thus does not take part in handling it. IOW, its HandlerProc is - * not called, instead we begin with the channel above it. + * and thus does not take part in handling it. IOW, its HandlerProc is not + * called, instead we begin with the channel above it. * - * This behaviour also allows the transformation channels to - * generate their own events and pass them upward. + * This behaviour also allows the transformation channels to generate + * their own events and pass them upward. */ while (mask && (chanPtr->upChanPtr != ((Channel *) NULL))) { @@ -6951,10 +6899,10 @@ Tcl_NotifyChannel(channel, mask) mask = (*upHandlerProc) (upChanPtr->instanceData, mask); } - /* ELSE: - * Ignore transformations which are unable to handle the event - * coming from below. Assume that they don't change the mask and - * pass it on. + /* + * ELSE: Ignore transformations which are unable to handle the event + * coming from below. Assume that they don't change the mask and pass + * it on. */ chanPtr = upChanPtr; @@ -6963,8 +6911,8 @@ Tcl_NotifyChannel(channel, mask) channel = (Tcl_Channel) chanPtr; /* - * Here we have either reached the top of the stack or the mask is - * empty. We break out of the procedure if it is the latter. + * Here we have either reached the top of the stack or the mask is empty. + * We break out of the procedure if it is the latter. */ if (!mask) { @@ -6972,8 +6920,8 @@ Tcl_NotifyChannel(channel, mask) } /* - * We are now above the topmost channel in a stack and have events - * left. Now call the channel handlers as usual. + * We are now above the topmost channel in a stack and have events left. + * Now call the channel handlers as usual. * * Preserve the channel struct in case the script closes it. */ @@ -6982,10 +6930,9 @@ Tcl_NotifyChannel(channel, mask) Tcl_Preserve((ClientData) statePtr); /* - * If we are flushing in the background, be sure to call FlushChannel - * for writable events. Note that we have to discard the writable - * event so we don't call any write handlers before the flush is - * complete. + * If we are flushing in the background, be sure to call FlushChannel for + * writable events. Note that we have to discard the writable event so we + * don't call any write handlers before the flush is complete. */ if ((statePtr->flags & BG_FLUSH_SCHEDULED) && (mask & TCL_WRITABLE)) { @@ -7018,9 +6965,9 @@ Tcl_NotifyChannel(channel, mask) } /* - * Update the notifier interest, since it may have changed after - * invoking event handlers. Skip that if the channel was deleted - * in the call to the channel handler. + * Update the notifier interest, since it may have changed after invoking + * event handlers. Skip that if the channel was deleted in the call to the + * channel handler. */ if (chanPtr->typePtr != NULL) { @@ -7038,8 +6985,8 @@ Tcl_NotifyChannel(channel, mask) * * UpdateInterest -- * - * Arrange for the notifier to call us back at appropriate times - * based on the current state of the channel. + * Arrange for the notifier to call us back at appropriate times based on + * the current state of the channel. * * Results: * None. @@ -7058,8 +7005,8 @@ UpdateInterest(chanPtr) int mask = statePtr->interestMask; /* - * If there are flushed buffers waiting to be written, then - * we need to watch for the channel to become writable. + * If there are flushed buffers waiting to be written, then we need to + * watch for the channel to become writable. */ if (statePtr->flags & BG_FLUSH_SCHEDULED) { @@ -7083,41 +7030,39 @@ UpdateInterest(chanPtr) /* * Andreas Kupries, April 11, 2003 * - * Some operating systems (Solaris 2.6 and higher (but not - * Solaris 2.5, go figure)) generate READABLE and - * EXCEPTION events when select()'ing [*] on a plain file, - * even if EOF was not yet reached. This is a problem in - * the following situation: + * Some operating systems (Solaris 2.6 and higher (but not Solaris + * 2.5, go figure)) generate READABLE and EXCEPTION events when + * select()'ing [*] on a plain file, even if EOF was not yet + * reached. This is a problem in the following situation: * - * - An extension asks to get both READABLE and EXCEPTION - * events. - * - It reads data into a buffer smaller than the buffer - * used by Tcl itself. - * - It does not process all events in the event queue, but - * only one, at least in some situations. + * - An extension asks to get both READABLE and EXCEPTION events. + * - It reads data into a buffer smaller than the buffer used by + * Tcl itself. + * - It does not process all events in the event queue, but only + * one, at least in some situations. * * In that case we can get into a situation where * * - Tcl drops READABLE here, because it has data in its own - * buffers waiting to be read by the extension. + * buffers waiting to be read by the extension. * - A READABLE event is syntesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCPTION event first, and - * handles this as EOF. + * - And the extension gets the EXCPTION event first, and handles + * this as EOF. * * End result ==> Premature end of reading from a file. * - * The concrete example is 'Expect', and its [expect] - * command (and at the C-level, deep in the bowels of - * Expect, 'exp_get_next_event'. See marker 'SunOS' for - * commentary in that function too). + * The concrete example is 'Expect', and its [expect] command + * (and at the C-level, deep in the bowels of Expect, + * 'exp_get_next_event'. See marker 'SunOS' for commentary in + * that function too). * - * [*] As the Tcl notifier does. See also for marker - * 'SunOS' in file 'exp_event.c' of Expect. + * [*] As the Tcl notifier does. See also for marker 'SunOS' in + * file 'exp_event.c' of Expect. * - * Our solution here is to drop the interest in the - * EXCEPTION events too. This compiles on all platforms, - * and also passes the testsuite on all of them. + * Our solution here is to drop the interest in the EXCEPTION + * events too. This compiles on all platforms, and also passes the + * testsuite on all of them. */ mask &= ~TCL_EXCEPTION; @@ -7136,8 +7081,8 @@ UpdateInterest(chanPtr) * * ChannelTimerProc -- * - * Timer handler scheduled by UpdateInterest to monitor the - * channel buffers until they are empty. + * Timer handler scheduled by UpdateInterest to monitor the channel + * buffers until they are empty. * * Results: * None. @@ -7161,19 +7106,20 @@ ChannelTimerProc(clientData) && (statePtr->inQueueHead->nextRemoved < statePtr->inQueueHead->nextAdded)) { /* - * Restart the timer in case a channel handler reenters the - * event loop before UpdateInterest gets called by Tcl_NotifyChannel. + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. */ statePtr->timer = Tcl_CreateTimerHandler(0, ChannelTimerProc, (ClientData) chanPtr); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - /* Set the TIMER flag to notify the higher levels that the - * driver might have no data for us. We do this only if we are - * in non-blocking mode and the driver has no BlockModeProc - * because only then we really don't know if the driver will - * block or not. A similar test is done in "PeekAhead". + /* + * Set the TIMER flag to notify the higher levels that the driver + * might have no data for us. We do this only if we are in + * non-blocking mode and the driver has no BlockModeProc because only + * then we really don't know if the driver will block or not. A + * similar test is done in "PeekAhead". */ if ((statePtr->flags & CHANNEL_NONBLOCKING) && @@ -7186,7 +7132,7 @@ ChannelTimerProc(clientData) Tcl_NotifyChannel((Tcl_Channel)chanPtr, TCL_READABLE); #ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING - statePtr->flags &= ~CHANNEL_TIMER_FEV; + statePtr->flags &= ~CHANNEL_TIMER_FEV; #endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */ Tcl_Release((ClientData) statePtr); @@ -7201,19 +7147,18 @@ ChannelTimerProc(clientData) * * Tcl_CreateChannelHandler -- * - * Arrange for a given procedure to be invoked whenever the - * channel indicated by the chanPtr arg becomes readable or - * writable. + * Arrange for a given procedure to be invoked whenever the channel + * indicated by the chanPtr arg becomes readable or writable. * * Results: * None. * * Side effects: - * From now on, whenever the I/O channel given by chanPtr becomes - * ready in the way indicated by mask, proc will be invoked. - * See the manual entry for details on the calling sequence - * to proc. If there is already an event handler for chan, proc - * and clientData, then the mask will be updated. + * From now on, whenever the I/O channel given by chanPtr becomes ready + * in the way indicated by mask, proc will be invoked. See the manual + * entry for details on the calling sequence to proc. If there is already + * an event handler for chan, proc and clientData, then the mask will be + * updated. * *---------------------------------------------------------------------- */ @@ -7222,12 +7167,12 @@ void Tcl_CreateChannelHandler(chan, mask, proc, clientData) Tcl_Channel chan; /* The channel to create the handler for. */ int mask; /* OR'ed combination of TCL_READABLE, - * TCL_WRITABLE, and TCL_EXCEPTION: - * indicates conditions under which - * proc should be called. Use 0 to - * disable a registered handler. */ - Tcl_ChannelProc *proc; /* Procedure to call for each - * selected event. */ + * TCL_WRITABLE, and TCL_EXCEPTION: indicates + * conditions under which proc should be + * called. Use 0 to disable a registered + * handler. */ + Tcl_ChannelProc *proc; /* Procedure to call for each selected + * event. */ ClientData clientData; /* Arbitrary data to pass to proc. */ { ChannelHandler *chPtr; @@ -7235,9 +7180,9 @@ Tcl_CreateChannelHandler(chan, mask, proc, clientData) ChannelState *statePtr = chanPtr->state; /* state info for channel */ /* - * Check whether this channel handler is not already registered. If - * it is not, create a new record, else reuse existing record (smash - * current values). + * Check whether this channel handler is not already registered. If it is + * not, create a new record, else reuse existing record (smash current + * values). */ for (chPtr = statePtr->chPtr; @@ -7259,16 +7204,15 @@ Tcl_CreateChannelHandler(chan, mask, proc, clientData) } /* - * The remainder of the initialization below is done regardless of - * whether or not this is a new record or a modification of an old - * one. + * The remainder of the initialization below is done regardless of whether + * or not this is a new record or a modification of an old one. */ chPtr->mask = mask; /* - * Recompute the interest mask for the channel - this call may actually - * be disabling an existing handler. + * Recompute the interest mask for the channel - this call may actually be + * disabling an existing handler. */ statePtr->interestMask = 0; @@ -7286,15 +7230,14 @@ Tcl_CreateChannelHandler(chan, mask, proc, clientData) * * Tcl_DeleteChannelHandler -- * - * Cancel a previously arranged callback arrangement for an IO - * channel. + * Cancel a previously arranged callback arrangement for an IO channel. * * Results: * None. * * Side effects: * If a callback was previously registered for this chan, proc and - * clientData , it is removed and the callback will no longer be called + * clientData, it is removed and the callback will no longer be called * when the channel becomes ready for IO. * *---------------------------------------------------------------------- @@ -7305,8 +7248,8 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) Tcl_Channel chan; /* The channel for which to remove the * callback. */ Tcl_ChannelProc *proc; /* The procedure in the callback to delete. */ - ClientData clientData; /* The client data in the callback - * to delete. */ + ClientData clientData; /* The client data in the callback to + * delete. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); ChannelHandler *chPtr, *prevChPtr; @@ -7362,8 +7305,7 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) /* * Recompute the interest list for the channel, so that infinite loops - * will not result if Tcl_DeleteChannelHandler is called inside an - * event. + * will not result if Tcl_DeleteChannelHandler is called inside an event. */ statePtr->interestMask = 0; @@ -7381,8 +7323,8 @@ Tcl_DeleteChannelHandler(chan, proc, clientData) * * DeleteScriptRecord -- * - * Delete a script record for this combination of channel, interp - * and mask. + * Delete a script record for this combination of channel, interp and + * mask. * * Results: * None. @@ -7397,10 +7339,10 @@ static void DeleteScriptRecord(interp, chanPtr, mask) Tcl_Interp *interp; /* Interpreter in which script was to be * executed. */ - Channel *chanPtr; /* The channel for which to delete the - * script record (if any). */ - int mask; /* Events in mask must exactly match mask - * of script to delete. */ + Channel *chanPtr; /* The channel for which to delete the script + * record (if any). */ + int mask; /* Events in mask must exactly match mask of + * script to delete. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ EventScriptRecord *esPtr, *prevEsPtr; @@ -7446,12 +7388,12 @@ DeleteScriptRecord(interp, chanPtr, mask) static void CreateScriptRecord(interp, chanPtr, mask, scriptPtr) - Tcl_Interp *interp; /* Interpreter in which to execute - * the stored script. */ - Channel *chanPtr; /* Channel for which script is to - * be stored. */ - int mask; /* Set of events for which script - * will be invoked. */ + Tcl_Interp *interp; /* Interpreter in which to execute the + * stored script. */ + Channel *chanPtr; /* Channel for which script is to be + * stored. */ + int mask; /* Set of events for which script will + * be invoked. */ Tcl_Obj *scriptPtr; /* Pointer to script object. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ @@ -7486,9 +7428,9 @@ CreateScriptRecord(interp, chanPtr, mask, scriptPtr) * * TclChannelEventScriptInvoker -- * - * Invokes a script scheduled by "fileevent" for when the channel - * becomes ready for IO. This function is invoked by the channel - * handler which was created by the Tcl "fileevent" command. + * Invokes a script scheduled by "fileevent" for when the channel becomes + * ready for IO. This function is invoked by the channel handler which + * was created by the Tcl "fileevent" command. * * Results: * None. @@ -7517,17 +7459,17 @@ TclChannelEventScriptInvoker(clientData, mask) interp = esPtr->interp; /* - * We must preserve the interpreter so we can report errors on it - * later. Note that we do not need to preserve the channel because - * that is done by Tcl_NotifyChannel before calling channel handlers. + * We must preserve the interpreter so we can report errors on it later. + * Note that we do not need to preserve the channel because that is done + * by Tcl_NotifyChannel before calling channel handlers. */ Tcl_Preserve((ClientData) interp); result = Tcl_EvalObjEx(interp, esPtr->scriptPtr, TCL_EVAL_GLOBAL); /* - * On error, cause a background error and remove the channel handler - * and the script record. + * On error, cause a background error and remove the channel handler and + * the script record. * * NOTE: Must delete channel handler before causing the background error * because the background error may want to reinstall the handler. @@ -7547,10 +7489,10 @@ TclChannelEventScriptInvoker(clientData, mask) * * Tcl_FileEventObjCmd -- * - * This procedure implements the "fileevent" Tcl command. See the - * user documentation for details on what it does. This command is - * based on the Tk command "fileevent" which in turn is based on work - * contributed by Mark Diekhans. + * This procedure implements the "fileevent" Tcl command. See the user + * documentation for details on what it does. This command is based on + * the Tk command "fileevent" which in turn is based on work contributed + * by Mark Diekhans. * * Results: * A standard Tcl result. @@ -7566,13 +7508,13 @@ int Tcl_FileEventObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Not used. */ Tcl_Interp *interp; /* Interpreter in which the channel - * for which to create the handler - * is found. */ + * for which to create the handler is + * found. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { - Channel *chanPtr; /* The channel to create - * the handler for. */ + Channel *chanPtr; /* The channel to create the handler + * for. */ ChannelState *statePtr; /* state info for channel */ Tcl_Channel chan; /* The opaque type for the channel. */ char *chanName; @@ -7632,9 +7574,9 @@ Tcl_FileEventObjCmd(clientData, interp, objc, objv) } /* - * Make the script record that will link between the event and the - * script to invoke. This also creates a channel event handler which - * will evaluate the script in the supplied interpreter. + * Make the script record that will link between the event and the script + * to invoke. This also creates a channel event handler which will + * evaluate the script in the supplied interpreter. */ CreateScriptRecord(interp, chanPtr, mask, objv[3]); @@ -7648,17 +7590,17 @@ Tcl_FileEventObjCmd(clientData, interp, objc, objv) * TclCopyChannel -- * * This routine copies data from one channel to another, either - * synchronously or asynchronously. If a command script is - * supplied, the operation runs in the background. The script - * is invoked when the copy completes. Otherwise the function - * waits until the copy is completed before returning. + * synchronously or asynchronously. If a command script is supplied, the + * operation runs in the background. The script is invoked when the copy + * completes. Otherwise the function waits until the copy is completed + * before returning. * * Results: * A standard Tcl result. * * Side effects: - * May schedule a background copy operation that causes both - * channels to be marked busy. + * May schedule a background copy operation that causes both channels to + * be marked busy. * *---------------------------------------------------------------------- */ @@ -7697,8 +7639,8 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) /* * Set up the blocking mode appropriately. Background copies need - * non-blocking channels. Foreground copies need blocking channels. - * If there is an error, restore the old blocking mode. + * non-blocking channels. Foreground copies need blocking channels. If + * there is an error, restore the old blocking mode. */ if (nonBlocking != (readFlags & CHANNEL_NONBLOCKING)) { @@ -7707,7 +7649,7 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) != TCL_OK) { return TCL_ERROR; } - } + } if (inPtr != outPtr) { if (nonBlocking != (writeFlags & CHANNEL_NONBLOCKING)) { if (SetBlockMode(NULL, outPtr, @@ -7764,8 +7706,8 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr) * * CopyData -- * - * This function implements the lowest level of the copying - * mechanism for TclCopyChannel. + * This function implements the lowest level of the copying mechanism for + * TclCopyChannel. * * Results: * Returns TCL_OK on success, else TCL_ERROR. @@ -7789,7 +7731,7 @@ CopyData(csPtr, mask) char *buffer; int inBinary, outBinary, sameEncoding; /* Encoding control */ - int underflow; /* input underflow */ + int underflow; /* input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; outChan = (Tcl_Channel) csPtr->writePtr; @@ -7801,9 +7743,9 @@ CopyData(csPtr, mask) /* * Copy the data the slow way, using the translation mechanism. * - * Note: We have make sure that we use the topmost channel in a stack - * for the copying. The caller uses Tcl_GetChannel to access it, and - * thus gets the bottom of the stack. + * Note: We have make sure that we use the topmost channel in a stack for + * the copying. The caller uses Tcl_GetChannel to access it, and thus gets + * the bottom of the stack. */ inBinary = (inStatePtr->encoding == NULL); @@ -7849,7 +7791,7 @@ CopyData(csPtr, mask) underflow = (size >= 0) && (size < sizeb); /* input underflow */ if (size < 0) { - readError: + readError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error reading \"", Tcl_GetChannelName(inChan), "\": ", @@ -7857,9 +7799,9 @@ CopyData(csPtr, mask) break; } else if (underflow) { /* - * We had an underflow on the read side. If we are at EOF, - * then the copying is done, otherwise set up a channel - * handler to detect when the channel becomes readable again. + * We had an underflow on the read side. If we are at EOF, then + * the copying is done, otherwise set up a channel handler to + * detect when the channel becomes readable again. */ if ((size == 0) && Tcl_Eof(inChan)) { @@ -7905,7 +7847,7 @@ CopyData(csPtr, mask) } /* else : Read counted characters, write counted bytes, i.e. size != sizeb */ if (sizeb < 0) { - writeError: + writeError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", Tcl_GetChannelName(outChan), "\": ", @@ -7914,10 +7856,10 @@ CopyData(csPtr, mask) } /* - * Update the current byte count. Do it now so the count is - * valid before a return or break takes us out of the loop. - * The invariant at the top of the loop should be that - * csPtr->toRead holds the number of bytes left to copy. + * Update the current byte count. Do it now so the count is valid + * before a return or break takes us out of the loop. The invariant at + * the top of the loop should be that csPtr->toRead holds the number + * of bytes left to copy. */ if (csPtr->toRead != -1) { @@ -7957,14 +7899,14 @@ CopyData(csPtr, mask) } /* - * For background copies, we only do one buffer per invocation so - * we don't starve the rest of the system. + * For background copies, we only do one buffer per invocation so we + * don't starve the rest of the system. */ if (cmdPtr) { /* - * The first time we enter this code, there won't be a - * channel handler established yet, so do it here. + * The first time we enter this code, there won't be a channel + * handler established yet, so do it here. */ if (mask == 0) { @@ -7985,16 +7927,16 @@ CopyData(csPtr, mask) } /* - * Make the callback or return the number of bytes transferred. - * The local total is used because StopCopy frees csPtr. + * Make the callback or return the number of bytes transferred. The local + * total is used because StopCopy frees csPtr. */ total = csPtr->total; if (cmdPtr) { /* - * Get a private copy of the command so we can mutate it - * by adding arguments. Note that StopCopy frees our saved - * reference to the original command obj. + * Get a private copy of the command so we can mutate it by adding + * arguments. Note that StopCopy frees our saved reference to the + * original command obj. */ cmdPtr = Tcl_DuplicateObj(cmdPtr); @@ -8035,8 +7977,8 @@ CopyData(csPtr, mask) * No encoding conversions are applied to the bytes being read. * * Results: - * The number of characters read, or -1 on error. Use Tcl_GetErrno() - * to retrieve the error code for the error that occurred. + * The number of characters read, or -1 on error. Use Tcl_GetErrno() to + * retrieve the error code for the error that occurred. * * Side effects: * May cause input to be buffered. @@ -8051,16 +7993,16 @@ DoRead(chanPtr, bufPtr, toRead) int toRead; /* Maximum number of bytes to read. */ { ChannelState *statePtr = chanPtr->state; /* state info for channel */ - int copied; /* How many characters were copied into - * the result string? */ - int copiedNow; /* How many characters were copied from - * the current input buffer? */ + int copied; /* How many characters were copied into the + * result string? */ + int copiedNow; /* How many characters were copied from the + * current input buffer? */ int result; /* Of calling GetInput. */ /* - * If we have not encountered a sticky EOF, clear the EOF bit. Either - * way clear the BLOCKED bit. We want to discover these anew during - * each operation. + * If we have not encountered a sticky EOF, clear the EOF bit. Either way + * clear the BLOCKED bit. We want to discover these anew during each + * operation. */ if (!(statePtr->flags & CHANNEL_STICKY_EOF)) { @@ -8093,12 +8035,12 @@ DoRead(chanPtr, bufPtr, toRead) statePtr->flags &= (~(CHANNEL_BLOCKED)); - done: /* - * Update the notifier state so we don't block while there is still - * data in the buffers. + * Update the notifier state so we don't block while there is still data + * in the buffers. */ + done: UpdateInterest(chanPtr); return copied; } @@ -8108,13 +8050,13 @@ DoRead(chanPtr, bufPtr, toRead) * * CopyAndTranslateBuffer -- * - * Copy at most one buffer of input to the result space, doing - * eol translations according to mode in effect currently. + * Copy at most one buffer of input to the result space, doing eol + * translations according to mode in effect currently. * * Results: - * Number of bytes stored in the result buffer (as opposed to the - * number of bytes read from the channel). May return - * zero if no input is available to be translated. + * Number of bytes stored in the result buffer (as opposed to the number + * of bytes read from the channel). May return zero if no input is + * available to be translated. * * Side effects: * Consumes buffered input. May deallocate one buffer. @@ -8126,22 +8068,22 @@ static int CopyAndTranslateBuffer(statePtr, result, space) ChannelState *statePtr; /* Channel state from which to read input. */ char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ + int space; /* How many bytes are available in result to + * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ + int bytesInBuffer; /* How many bytes are available to be copied + * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ - int i; /* Iterates over the copied input looking - * for the input eofChar. */ + int i; /* Iterates over the copied input looking for + * the input eofChar. */ /* * If there is no input at all, return zero. The invariant is that either - * there is no buffer in the queue, or if the first buffer is empty, it - * is also the last buffer (and thus there is no input in the queue). - * Note also that if the buffer is empty, we leave it in the queue. + * there is no buffer in the queue, or if the first buffer is empty, it is + * also the last buffer (and thus there is no input in the queue). Note + * also that if the buffer is empty, we leave it in the queue. */ if (statePtr->inQueueHead == (ChannelBuffer *) NULL) { @@ -8152,165 +8094,157 @@ CopyAndTranslateBuffer(statePtr, result, space) copied = 0; switch (statePtr->inputTranslation) { - case TCL_TRANSLATE_LF: { - if (bytesInBuffer == 0) { - return 0; - } + case TCL_TRANSLATE_LF: + if (bytesInBuffer == 0) { + return 0; + } - /* - * Copy the current chunk into the result buffer. - */ + /* + * Copy the current chunk into the result buffer. + */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - break; + if (bytesInBuffer < space) { + space = bytesInBuffer; } - case TCL_TRANSLATE_CR: { - char *end; + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + break; + case TCL_TRANSLATE_CR: { + char *end; - if (bytesInBuffer == 0) { - return 0; - } + if (bytesInBuffer == 0) { + return 0; + } - /* - * Copy the current chunk into the result buffer, then - * replace all \r with \n. - */ + /* + * Copy the current chunk into the result buffer, then replace all \r + * with \n. + */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - for (end = result + copied; result < end; result++) { - if (*result == '\r') { - *result = '\n'; - } + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + for (end = result + copied; result < end; result++) { + if (*result == '\r') { + *result = '\n'; } - break; } - case TCL_TRANSLATE_CRLF: { - char *src, *end, *dst; - int curByte; + break; + } + case TCL_TRANSLATE_CRLF: { + char *src, *end, *dst; + int curByte; - /* - * If there is a held-back "\r" at EOF, produce it now. - */ + /* + * If there is a held-back "\r" at EOF, produce it now. + */ - if (bytesInBuffer == 0) { - if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == - (INPUT_SAW_CR | CHANNEL_EOF)) { - result[0] = '\r'; - statePtr->flags &= ~INPUT_SAW_CR; - return 1; - } - return 0; + if (bytesInBuffer == 0) { + if ((statePtr->flags & (INPUT_SAW_CR | CHANNEL_EOF)) == + (INPUT_SAW_CR | CHANNEL_EOF)) { + result[0] = '\r'; + statePtr->flags &= ~INPUT_SAW_CR; + return 1; } + return 0; + } - /* - * Copy the current chunk and replace "\r\n" with "\n" - * (but not standalone "\r"!). - */ + /* + * Copy the current chunk and replace "\r\n" with "\n" + * (but not standalone "\r"!). + */ + + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; - if (bytesInBuffer < space) { - space = bytesInBuffer; + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\n') { + statePtr->flags &= ~INPUT_SAW_CR; + } else if (statePtr->flags & INPUT_SAW_CR) { + statePtr->flags &= ~INPUT_SAW_CR; + *dst = '\r'; + dst++; } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\n') { - statePtr->flags &= ~INPUT_SAW_CR; - } else if (statePtr->flags & INPUT_SAW_CR) { - statePtr->flags &= ~INPUT_SAW_CR; - *dst = '\r'; - dst++; - } - if (curByte == '\r') { - statePtr->flags |= INPUT_SAW_CR; - } else { - *dst = (char) curByte; - dst++; - } + if (curByte == '\r') { + statePtr->flags |= INPUT_SAW_CR; + } else { + *dst = (char) curByte; + dst++; } - copied = dst - result; - break; } - case TCL_TRANSLATE_AUTO: { - char *src, *end, *dst; - int curByte; + copied = dst - result; + break; + } + case TCL_TRANSLATE_AUTO: { + char *src, *end, *dst; + int curByte; - if (bytesInBuffer == 0) { - return 0; - } + if (bytesInBuffer == 0) { + return 0; + } - /* - * Loop over the current buffer, converting "\r" and "\r\n" - * to "\n". - */ + /* + * Loop over the current buffer, converting "\r" and "\r\n" to "\n". + */ - if (bytesInBuffer < space) { - space = bytesInBuffer; - } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); - bufPtr->nextRemoved += space; - copied = space; - - end = result + copied; - dst = result; - for (src = result; src < end; src++) { - curByte = *src; - if (curByte == '\r') { - statePtr->flags |= INPUT_SAW_CR; - *dst = '\n'; + if (bytesInBuffer < space) { + space = bytesInBuffer; + } + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); + bufPtr->nextRemoved += space; + copied = space; + + end = result + copied; + dst = result; + for (src = result; src < end; src++) { + curByte = *src; + if (curByte == '\r') { + statePtr->flags |= INPUT_SAW_CR; + *dst = '\n'; + dst++; + } else { + if ((curByte != '\n') || !(statePtr->flags & INPUT_SAW_CR)) { + *dst = (char) curByte; dst++; - } else { - if ((curByte != '\n') || - !(statePtr->flags & INPUT_SAW_CR)) { - *dst = (char) curByte; - dst++; - } - statePtr->flags &= ~INPUT_SAW_CR; } + statePtr->flags &= ~INPUT_SAW_CR; } - copied = dst - result; - break; - } - default: { - Tcl_Panic("unknown eol translation mode"); } + copied = dst - result; + break; + } + default: + Tcl_Panic("unknown eol translation mode"); } /* - * If an in-stream EOF character is set for this channel, check that - * the input we copied so far does not contain the EOF char. If it does, - * copy only up to and excluding that character. + * If an in-stream EOF character is set for this channel, check that the + * input we copied so far does not contain the EOF char. If it does, copy + * only up to and excluding that character. */ if (statePtr->inEofChar != 0) { for (i = 0; i < copied; i++) { if (result[i] == (char) statePtr->inEofChar) { /* - * Set sticky EOF so that no further input is presented - * to the caller. + * Set sticky EOF so that no further input is presented to the + * caller. */ statePtr->flags |= (CHANNEL_EOF | CHANNEL_STICKY_EOF); @@ -8334,9 +8268,9 @@ CopyAndTranslateBuffer(statePtr, result, space) } /* - * Return the number of characters copied into the result buffer. - * This may be different from the number of bytes consumed, because - * of EOL translations. + * Return the number of characters copied into the result buffer. This may + * be different from the number of bytes consumed, because of EOL + * translations. */ return copied; @@ -8350,8 +8284,8 @@ CopyAndTranslateBuffer(statePtr, result, space) * Copy at most one buffer of input to the result space. * * Results: - * Number of bytes stored in the result buffer. May return - * zero if no input is available. + * Number of bytes stored in the result buffer. May return zero if no + * input is available. * * Side effects: * Consumes buffered input. May deallocate one buffer. @@ -8363,21 +8297,21 @@ static int CopyBuffer(chanPtr, result, space) Channel *chanPtr; /* Channel from which to read input. */ char *result; /* Where to store the copied input. */ - int space; /* How many bytes are available in result - * to store the copied input? */ + int space; /* How many bytes are available in result to + * store the copied input? */ { ChannelBuffer *bufPtr; /* The buffer from which to copy bytes. */ - int bytesInBuffer; /* How many bytes are available to be - * copied in the current input buffer? */ + int bytesInBuffer; /* How many bytes are available to be copied + * in the current input buffer? */ int copied; /* How many characters were already copied * into the destination space? */ /* - * If there is no input at all, return zero. The invariant is that - * either there is no buffer in the queue, or if the first buffer - * is empty, it is also the last buffer (and thus there is no - * input in the queue). Note also that if the buffer is empty, we - * don't leave it in the queue, but recycle it. + * If there is no input at all, return zero. The invariant is that either + * there is no buffer in the queue, or if the first buffer is empty, it is + * also the last buffer (and thus there is no input in the queue). Note + * also that if the buffer is empty, we don't leave it in the queue, but + * recycle it. */ if (chanPtr->inQueueHead == (ChannelBuffer *) NULL) { @@ -8403,16 +8337,15 @@ CopyBuffer(chanPtr, result, space) space = bytesInBuffer; } - memcpy((VOID *) result, - (VOID *) (bufPtr->buf + bufPtr->nextRemoved), - (size_t) space); + memcpy((VOID *) result, (VOID *) (bufPtr->buf + bufPtr->nextRemoved), + (size_t) space); bufPtr->nextRemoved += space; copied = space; /* - * We don't care about in-stream EOF characters here as the data - * read here may still flow through one or more transformations, - * i.e. is not in its final state yet. + * We don't care about in-stream EOF characters here as the data read here + * may still flow through one or more transformations, i.e. is not in its + * final state yet. */ /* @@ -8468,16 +8401,16 @@ DoWrite(chanPtr, src, srcLen) CONST char *sPtr; /* Search variables for newline. */ int crsent; /* In CRLF eol translation mode, * remember the fact that a CR was - * output to the channel without - * its following NL. */ + * output to the channel without its + * following NL. */ int i; /* Loop index for newline search. */ int destCopied; /* How many bytes were used in this * destination buffer to hold the * output? */ - int totalDestCopied; /* How many bytes total were - * copied to the channel buffer? */ - int srcCopied; /* How many bytes were copied from - * the source string? */ + int totalDestCopied; /* How many bytes total were copied to + * the channel buffer? */ + int srcCopied; /* How many bytes were copied from the + * source string? */ char *destPtr; /* Where in line to copy to? */ /* @@ -8514,41 +8447,41 @@ DoWrite(chanPtr, src, srcLen) destPtr = outBufPtr->buf + outBufPtr->nextAdded; switch (statePtr->outputTranslation) { - case TCL_TRANSLATE_LF: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); - break; - case TCL_TRANSLATE_CR: - srcCopied = destCopied; - memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); - for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { - if (*dPtr == '\n') { - *dPtr = '\r'; - } + case TCL_TRANSLATE_LF: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + break; + case TCL_TRANSLATE_CR: + srcCopied = destCopied; + memcpy((VOID *) destPtr, (VOID *) src, (size_t) destCopied); + for (dPtr = destPtr; dPtr < destPtr + destCopied; dPtr++) { + if (*dPtr == '\n') { + *dPtr = '\r'; } - break; - case TCL_TRANSLATE_CRLF: - for (srcCopied = 0, dPtr = destPtr, sPtr = src; - dPtr < destPtr + destCopied; - dPtr++, sPtr++, srcCopied++) { - if (*sPtr == '\n') { - if (crsent) { - *dPtr = '\n'; - crsent = 0; - } else { - *dPtr = '\r'; - crsent = 1; - sPtr--, srcCopied--; - } + } + break; + case TCL_TRANSLATE_CRLF: + for (srcCopied = 0, dPtr = destPtr, sPtr = src; + dPtr < destPtr + destCopied; + dPtr++, sPtr++, srcCopied++) { + if (*sPtr == '\n') { + if (crsent) { + *dPtr = '\n'; + crsent = 0; } else { - *dPtr = *sPtr; + *dPtr = '\r'; + crsent = 1; + sPtr--, srcCopied--; } + } else { + *dPtr = *sPtr; } - break; - case TCL_TRANSLATE_AUTO: - Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); - default: - Tcl_Panic("Tcl_Write: unknown output translation mode"); + } + break; + case TCL_TRANSLATE_AUTO: + Tcl_Panic("Tcl_Write: AUTO output translation mode not supported"); + default: + Tcl_Panic("Tcl_Write: unknown output translation mode"); } /* @@ -8597,9 +8530,9 @@ DoWrite(chanPtr, src, srcLen) * * CopyEventProc -- * - * This routine is invoked as a channel event handler for - * the background copy operation. It is just a trivial wrapper - * around the CopyData routine. + * This routine is invoked as a channel event handler for the background + * copy operation. It is just a trivial wrapper around the CopyData + * routine. * * Results: * None. @@ -8615,7 +8548,7 @@ CopyEventProc(clientData, mask) ClientData clientData; int mask; { - (void) CopyData((CopyState *)clientData, mask); + (void) CopyData((CopyState *) clientData, mask); } /* @@ -8629,8 +8562,8 @@ CopyEventProc(clientData, mask) * None. * * Side effects: - * Removes any pending channel handlers and restores the blocking - * and buffering modes of the channels. The CopyState is freed. + * Removes any pending channel handlers and restores the blocking and + * buffering modes of the channels. The CopyState is freed. * *---------------------------------------------------------------------- */ @@ -8667,14 +8600,14 @@ StopCopy(csPtr) } outStatePtr->flags &= ~(CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); outStatePtr->flags |= - csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); + csPtr->writeFlags & (CHANNEL_LINEBUFFERED | CHANNEL_UNBUFFERED); if (csPtr->cmdPtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->readPtr, CopyEventProc, - (ClientData)csPtr); + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->readPtr, CopyEventProc, + (ClientData) csPtr); if (csPtr->readPtr != csPtr->writePtr) { - Tcl_DeleteChannelHandler((Tcl_Channel)csPtr->writePtr, - CopyEventProc, (ClientData)csPtr); + Tcl_DeleteChannelHandler((Tcl_Channel) csPtr->writePtr, + CopyEventProc, (ClientData) csPtr); } TclDecrRefCount(csPtr->cmdPtr); } @@ -8688,15 +8621,15 @@ StopCopy(csPtr) * * StackSetBlockMode -- * - * This function sets the blocking mode for a channel, iterating - * through each channel in a stack and updates the state flags. + * This function sets the blocking mode for a channel, iterating through + * each channel in a stack and updates the state flags. * * Results: * 0 if OK, result code from failed blockModeProc otherwise. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Modifies the blocking mode of the channel and possibly generates an + * error. * *---------------------------------------------------------------------- */ @@ -8734,15 +8667,15 @@ StackSetBlockMode(chanPtr, mode) * * SetBlockMode -- * - * This function sets the blocking mode for a channel and updates - * the state flags. + * This function sets the blocking mode for a channel and updates the + * state flags. * * Results: * A standard Tcl result. * * Side effects: - * Modifies the blocking mode of the channel and possibly generates - * an error. + * Modifies the blocking mode of the channel and possibly generates an + * error. * *---------------------------------------------------------------------- */ @@ -8801,9 +8734,9 @@ Tcl_GetChannelNames(interp) * * Tcl_GetChannelNamesEx -- * - * Return the names of open channels in the interp filtered - * filtered through a pattern. If pattern is NULL, it returns - * all the open channels. + * Return the names of open channels in the interp filtered filtered + * through a pattern. If pattern is NULL, it returns all the open + * channels. * * Results: * TCL_OK or TCL_ERROR. @@ -8832,8 +8765,8 @@ Tcl_GetChannelNamesEx(interp, pattern) } /* - * Get the channel table that stores the channels registered - * for this interpreter. + * Get the channel table that stores the channels registered for this + * interpreter. */ hTblPtr = GetChannelTable(interp); @@ -8861,8 +8794,8 @@ Tcl_GetChannelNamesEx(interp, pattern) name = "stderr"; } else { /* - * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), - * but it's simpler to just grab the name from the statePtr. + * This is also stored in Tcl_GetHashKey(hTblPtr, hPtr), but it's + * simpler to just grab the name from the statePtr. */ name = statePtr->channelName; @@ -8871,12 +8804,13 @@ Tcl_GetChannelNamesEx(interp, pattern) if (((pattern == NULL) || Tcl_StringMatch(name, pattern)) && (Tcl_ListObjAppendElement(interp, resultPtr, Tcl_NewStringObj(name, -1)) != TCL_OK)) { -error: + error: TclDecrRefCount(resultPtr); return TCL_ERROR; } } -done: + + done: Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } @@ -8886,8 +8820,8 @@ done: * * Tcl_IsChannelRegistered -- * - * Checks whether the channel is associated with the interp. - * See also Tcl_RegisterChannel and Tcl_UnregisterChannel. + * Checks whether the channel is associated with the interp. See also + * Tcl_RegisterChannel and Tcl_UnregisterChannel. * * Results: * 0 if the channel is not registered in the interpreter, 1 else. @@ -8900,8 +8834,8 @@ done: int Tcl_IsChannelRegistered(interp, chan) - Tcl_Interp *interp; /* The interp to query of the channel */ - Tcl_Channel chan; /* The channel to check */ + Tcl_Interp *interp; /* The interp to query of the channel */ + Tcl_Channel chan; /* The channel to check */ { Tcl_HashTable *hTblPtr; /* Hash table of channels. */ Tcl_HashEntry *hPtr; /* Search variable. */ @@ -8909,8 +8843,8 @@ Tcl_IsChannelRegistered(interp, chan) ChannelState *statePtr; /* State of the real channel. */ /* - * Always check bottom-most channel in the stack. This is the one - * that gets registered. + * Always check bottom-most channel in the stack. This is the one that + * gets registered. */ chanPtr = ((Channel *) chan)->state->bottomChanPtr; @@ -8963,8 +8897,8 @@ Tcl_IsChannelShared(chan) * Tcl_IsChannelExisting -- * * Checks whether a channel of the given name exists in the - * (thread)-global list of all channels. - * See Tcl_GetChannelNamesEx for function exposed at the Tcl level. + * (thread)-global list of all channels. See Tcl_GetChannelNamesEx for + * function exposed at the Tcl level. * * Results: * A boolean value (0 = Does not exist, 1 = Does exist). @@ -9058,8 +8992,8 @@ Tcl_ChannelVersion(chanTypePtr) return TCL_CHANNEL_VERSION_4; } else { /* - * In flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? channelId"); iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; @@ -328,7 +330,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) } if (i == objc) { - goto argerror; + goto argerror; } name = Tcl_GetString(objv[i]); @@ -337,25 +339,25 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", name, - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", name, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } i++; /* Consumed channel name. */ /* - * Compute how many bytes to read, and see whether the final - * newline should be dropped. + * Compute how many bytes to read, and see whether the final newline + * should be dropped. */ toRead = -1; if (i < objc) { char *arg; - + arg = Tcl_GetString(objv[i]); if (isdigit(UCHAR(arg[0]))) { /* INTL: digit */ if (Tcl_GetIntFromObj(interp, objv[i], &toRead) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } } else if (strcmp(arg, "nonewline") == 0) { newline = 1; @@ -363,7 +365,7 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_AppendResult(interp, "bad argument \"", arg, "\": should be \"nonewline\"", (char *) NULL); return TCL_ERROR; - } + } } resultPtr = Tcl_NewObj(); @@ -376,11 +378,11 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_DecrRefCount(resultPtr); return TCL_ERROR; } - + /* * If requested, remove the last newline in the channel if at EOF. */ - + if ((charactersRead > 0) && (newline != 0)) { char *result; int length; @@ -400,15 +402,15 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) * * Tcl_SeekObjCmd -- * - * This procedure is invoked to process the Tcl "seek" command. See - * the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "seek" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves the position of the access point on the specified channel. - * May flush queued output. + * Moves the position of the access point on the specified channel. May + * flush queued output. * *---------------------------------------------------------------------- */ @@ -455,9 +457,9 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { - Tcl_AppendResult(interp, "error during seek on \"", + Tcl_AppendResult(interp, "error during seek on \"", chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); - return TCL_ERROR; + return TCL_ERROR; } return TCL_OK; } @@ -467,8 +469,8 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) * * Tcl_TellObjCmd -- * - * This procedure is invoked to process the Tcl "tell" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "tell" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -494,11 +496,12 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) Tcl_WrongNumArgs(interp, 1, objv, "channelId"); return TCL_ERROR; } + /* - * Try to find a channel with the right name and permissions in - * the IO channel table of this interpreter. + * Try to find a channel with the right name and permissions in the IO + * channel table of this interpreter. */ - + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { @@ -513,8 +516,8 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) * * Tcl_CloseObjCmd -- * - * This procedure is invoked to process the Tcl "close" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "close" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -548,31 +551,31 @@ Tcl_CloseObjCmd(clientData, interp, objc, objv) } if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) { - /* - * If there is an error message and it ends with a newline, remove - * the newline. This is done for command pipeline channels where the - * error output from the subprocesses is stored in interp's result. - * - * NOTE: This is likely to not have any effect on regular error - * messages produced by drivers during the closing of a channel, - * because the Tcl convention is that such error messages do not - * have a terminating newline. - */ + /* + * If there is an error message and it ends with a newline, remove the + * newline. This is done for command pipeline channels where the error + * output from the subprocesses is stored in interp's result. + * + * NOTE: This is likely to not have any effect on regular error + * messages produced by drivers during the closing of a channel, + * because the Tcl convention is that such error messages do not have + * a terminating newline. + */ Tcl_Obj *resultPtr; char *string; int len; - + resultPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(resultPtr)) { resultPtr = Tcl_DuplicateObj(resultPtr); Tcl_SetObjResult(interp, resultPtr); } string = Tcl_GetStringFromObj(resultPtr, &len); - if ((len > 0) && (string[len - 1] == '\n')) { + if ((len > 0) && (string[len - 1] == '\n')) { Tcl_SetObjLength(resultPtr, len - 1); - } - return TCL_ERROR; + } + return TCL_ERROR; } return TCL_OK; @@ -606,46 +609,49 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) char *chanName, *optionName, *valueName; Tcl_Channel chan; /* The channel to set a mode on. */ int i; /* Iterate over arg-value pairs. */ - Tcl_DString ds; /* DString to hold result of - * calling Tcl_GetChannelOption. */ + Tcl_DString ds; /* DString to hold result of calling + * Tcl_GetChannelOption. */ if ((objc < 2) || (((objc % 2) == 1) && (objc != 3))) { Tcl_WrongNumArgs(interp, 1, objv, "channelId ?optionName? ?value? ?optionName value?..."); - return TCL_ERROR; + return TCL_ERROR; } + chanName = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } + if (objc == 2) { - Tcl_DStringInit(&ds); - if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { + Tcl_DStringInit(&ds); + if (Tcl_GetChannelOption(interp, chan, (char *) NULL, &ds) != TCL_OK) { Tcl_DStringFree(&ds); return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; - } - if (objc == 3) { - Tcl_DStringInit(&ds); + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; + } else if (objc == 3) { + Tcl_DStringInit(&ds); optionName = Tcl_GetString(objv[2]); - if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringResult(interp, &ds); - return TCL_OK; + if (Tcl_GetChannelOption(interp, chan, optionName, &ds) != TCL_OK) { + Tcl_DStringFree(&ds); + return TCL_ERROR; + } + Tcl_DStringResult(interp, &ds); + return TCL_OK; } + for (i = 3; i < objc; i += 2) { optionName = Tcl_GetString(objv[i-1]); valueName = Tcl_GetString(objv[i]); - if (Tcl_SetChannelOption(interp, chan, optionName, valueName) + if (Tcl_SetChannelOption(interp, chan, optionName, valueName) != TCL_OK) { - return TCL_ERROR; - } + return TCL_ERROR; + } } + return TCL_OK; } @@ -654,15 +660,15 @@ Tcl_FconfigureObjCmd(clientData, interp, objc, objv) * * Tcl_EofObjCmd -- * - * This procedure is invoked to process the Tcl "eof" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "eof" command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether - * the specified channel has an EOF condition. + * Sets interp's result to boolean true or false depending on whether the + * specified channel has an EOF condition. * *--------------------------------------------------------------------------- */ @@ -681,7 +687,7 @@ Tcl_EofObjCmd(unused, interp, objc, objv) if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); @@ -699,8 +705,8 @@ Tcl_EofObjCmd(unused, interp, objc, objv) * * Tcl_ExecObjCmd -- * - * This procedure is invoked to process the "exec" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "exec" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -773,13 +779,12 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) string = Tcl_GetString(objv[objc - 1]); if ((string[0] == '&') && (string[1] == '\0')) { objc--; - background = 1; + background = 1; } /* - * Create the string argument array "argv". Make sure argv is large - * enough to hold the argc arguments plus 1 extra for the zero - * end-of-argv word. + * Create the string argument array "argv". Make sure argv is large enough + * to hold the argc arguments plus 1 extra for the zero end-of-argv word. */ argv = argStorage; @@ -798,7 +803,7 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) } argv[argc] = NULL; chan = Tcl_OpenCommandChannel(interp, argc, argv, - (background ? 0 : TCL_STDOUT | TCL_STDERR)); + (background ? 0 : TCL_STDOUT | TCL_STDERR)); /* * Free the argv array if malloc'ed storage was used. @@ -813,15 +818,15 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) } if (background) { - /* + /* * Store the list of PIDs from the pipeline in interp's result and * detach the PIDs (instead of waiting for them). */ - TclGetAndDetachPids(interp, chan); - if (Tcl_Close(interp, chan) != TCL_OK) { + TclGetAndDetachPids(interp, chan); + if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; - } + } return TCL_OK; } @@ -835,20 +840,21 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } } + /* - * If the process produced anything on stderr, it will have been - * returned in the interpreter result. It needs to be appended to - * the result string. + * If the process produced anything on stderr, it will have been returned + * in the interpreter result. It needs to be appended to the result + * string. */ result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* - * If the last character of the result is a newline, then remove - * the newline character. + * If the last character of the result is a newline, then remove the + * newline character. */ - + if (keepNewline == 0) { string = Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (string[length - 1] == '\n')) { @@ -865,15 +871,15 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) * * Tcl_FblockedObjCmd -- * - * This procedure is invoked to process the Tcl "fblocked" command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the Tcl "fblocked" command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Sets interp's result to boolean true or false depending on whether - * the preceeding input operation on the channel would have blocked. + * Sets interp's result to boolean true or false depending on whether the + * preceeding input operation on the channel would have blocked. * *--------------------------------------------------------------------------- */ @@ -892,20 +898,20 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); - return TCL_ERROR; + return TCL_ERROR; } arg = Tcl_GetString(objv[1]); chan = Tcl_GetChannel(interp, arg, &mode); if (chan == NULL) { - return TCL_ERROR; + return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", - arg, "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } - + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_InputBlocked(chan))); return TCL_OK; } @@ -915,8 +921,8 @@ Tcl_FblockedObjCmd(unused, interp, objc, objv) * * Tcl_OpenObjCmd -- * - * This procedure is invoked to process the "open" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "open" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -966,43 +972,44 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) */ if (!pipeline) { - chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); + chan = Tcl_FSOpenFileChannel(interp, objv[1], modeString, prot); } else { int mode, seekFlag, cmdObjc, binary; CONST char **cmdArgv; - if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { - return TCL_ERROR; - } + if (Tcl_SplitList(interp, what+1, &cmdObjc, &cmdArgv) != TCL_OK) { + return TCL_ERROR; + } - mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); - if (mode == -1) { + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); + if (mode == -1) { chan = NULL; - } else { + } else { int flags = TCL_STDERR | TCL_ENFORCE_MODE; + switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { - case O_RDONLY: - flags |= TCL_STDOUT; - break; - case O_WRONLY: - flags |= TCL_STDIN; - break; - case O_RDWR: - flags |= (TCL_STDIN | TCL_STDOUT); - break; - default: - Tcl_Panic("Tcl_OpenCmd: invalid mode value"); - break; + case O_RDONLY: + flags |= TCL_STDOUT; + break; + case O_WRONLY: + flags |= TCL_STDIN; + break; + case O_RDWR: + flags |= (TCL_STDIN | TCL_STDOUT); + break; + default: + Tcl_Panic("Tcl_OpenCmd: invalid mode value"); + break; } chan = Tcl_OpenCommandChannel(interp, cmdObjc, cmdArgv, flags); if (binary) { Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - ckfree((char *) cmdArgv); + ckfree((char *) cmdArgv); } if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + return TCL_ERROR; } Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); @@ -1014,18 +1021,18 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) * * TcpAcceptCallbacksDeleteProc -- * - * Assocdata cleanup routine called when an interpreter is being - * deleted to set the interp field of all the accept callback records - * registered with the interpreter to NULL. This will prevent the - * interpreter from being used in the future to eval accept scripts. + * Assocdata cleanup routine called when an interpreter is being deleted + * to set the interp field of all the accept callback records registered + * with the interpreter to NULL. This will prevent the interpreter from + * being used in the future to eval accept scripts. * * Results: * None. * * Side effects: * Deallocates memory and sets the interp field of all the accept - * callback records to NULL to prevent this interpreter from being - * used subsequently to eval accept scripts. + * callback records to NULL to prevent this interpreter from being used + * subsequently to eval accept scripts. * *---------------------------------------------------------------------- */ @@ -1034,7 +1041,7 @@ Tcl_OpenObjCmd(notUsed, interp, objc, objv) static void TcpAcceptCallbacksDeleteProc(clientData, interp) ClientData clientData; /* Data which was passed when the assocdata - * was registered. */ + * was registered. */ Tcl_Interp *interp; /* Interpreter being deleted - not used. */ { Tcl_HashTable *hTblPtr; @@ -1044,10 +1051,10 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) hTblPtr = (Tcl_HashTable *) clientData; for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); - acceptCallbackPtr->interp = (Tcl_Interp *) NULL; + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + acceptCallbackPtr = (AcceptCallback *) Tcl_GetHashValue(hPtr); + acceptCallbackPtr->interp = (Tcl_Interp *) NULL; } Tcl_DeleteHashTable(hTblPtr); ckfree((char *) hTblPtr); @@ -1058,17 +1065,16 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) * * RegisterTcpServerInterpCleanup -- * - * Registers an accept callback record to have its interp - * field set to NULL when the interpreter is deleted. + * Registers an accept callback record to have its interp field set to + * NULL when the interpreter is deleted. * * Results: * None. * * Side effects: - * When, in the future, the interpreter is deleted, the interp - * field of the accept callback data structure will be set to - * NULL. This will prevent attempts to eval the accept script - * in a deleted interpreter. + * When, in the future, the interpreter is deleted, the interp field of + * the accept callback data structure will be set to NULL. This will + * prevent attempts to eval the accept script in a deleted interpreter. * *---------------------------------------------------------------------- */ @@ -1076,30 +1082,29 @@ TcpAcceptCallbacksDeleteProc(clientData, interp) static void RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter for which we want to be - * informed of deletion. */ + * informed of deletion. */ AcceptCallback *acceptCallbackPtr; - /* The accept callback record whose - * interp field we want set to NULL when - * the interpreter is deleted. */ + /* The accept callback record whose interp + * field we want set to NULL when the + * interpreter is deleted. */ { - Tcl_HashTable *hTblPtr; /* Hash table for accept callback - * records to smash when the interpreter - * will be deleted. */ + Tcl_HashTable *hTblPtr; /* Hash table for accept callback records to + * smash when the interpreter will be + * deleted. */ Tcl_HashEntry *hPtr; /* Entry for this record. */ int new; /* Is the entry new? */ hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", - NULL); + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); - Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); - (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", - TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); + hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable)); + Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); + (void) Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", + TcpAcceptCallbacksDeleteProc, (ClientData) hTblPtr); } hPtr = Tcl_CreateHashEntry(hTblPtr, (char *) acceptCallbackPtr, &new); if (!new) { - Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); + Tcl_Panic("RegisterTcpServerCleanup: damaged accept record table"); } Tcl_SetHashValue(hPtr, (ClientData) acceptCallbackPtr); } @@ -1109,16 +1114,16 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) * * UnregisterTcpServerInterpCleanupProc -- * - * Unregister a previously registered accept callback record. The - * interp field of this record will no longer be set to NULL in - * the future when the interpreter is deleted. + * Unregister a previously registered accept callback record. The interp + * field of this record will no longer be set to NULL in the future when + * the interpreter is deleted. * * Results: * None. * * Side effects: - * Prevents the interp field of the accept callback record from - * being set to NULL in the future when the interpreter is deleted. + * Prevents the interp field of the accept callback record from being set + * to NULL in the future when the interpreter is deleted. * *---------------------------------------------------------------------- */ @@ -1126,22 +1131,22 @@ RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr) static void UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) Tcl_Interp *interp; /* Interpreter in which the accept callback - * record was registered. */ + * record was registered. */ AcceptCallback *acceptCallbackPtr; - /* The record for which to delete the - * registration. */ + /* The record for which to delete the + * registration. */ { Tcl_HashTable *hTblPtr; Tcl_HashEntry *hPtr; hTblPtr = (Tcl_HashTable *) Tcl_GetAssocData(interp, - "tclTCPAcceptCallbacks", NULL); + "tclTCPAcceptCallbacks", NULL); if (hTblPtr == (Tcl_HashTable *) NULL) { - return; + return; } hPtr = Tcl_FindHashEntry(hTblPtr, (char *) acceptCallbackPtr); if (hPtr == (Tcl_HashEntry *) NULL) { - return; + return; } Tcl_DeleteHashEntry(hPtr); } @@ -1151,8 +1156,8 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) * * AcceptCallbackProc -- * - * This callback is invoked by the TCP channel driver when it - * accepts a new connection from a client on a server socket. + * This callback is invoked by the TCP channel driver when it accepts a + * new connection from a client on a server socket. * * Results: * None. @@ -1166,12 +1171,12 @@ UnregisterTcpServerInterpCleanupProc(interp, acceptCallbackPtr) static void AcceptCallbackProc(callbackData, chan, address, port) ClientData callbackData; /* The data stored when the callback - * was created in the call to - * Tcl_OpenTcpServer. */ + * was created in the call to + * Tcl_OpenTcpServer. */ Tcl_Channel chan; /* Channel for the newly accepted - * connection. */ + * connection. */ char *address; /* Address of client that was - * accepted. */ + * accepted. */ int port; /* Port of client that was accepted. */ { AcceptCallback *acceptCallbackPtr; @@ -1187,49 +1192,49 @@ AcceptCallbackProc(callbackData, chan, address, port) * away, this is signalled by setting the interp field of the callback * data to NULL. */ - + if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - script = acceptCallbackPtr->script; - interp = acceptCallbackPtr->interp; - - Tcl_Preserve((ClientData) script); - Tcl_Preserve((ClientData) interp); + script = acceptCallbackPtr->script; + interp = acceptCallbackPtr->interp; + + Tcl_Preserve((ClientData) script); + Tcl_Preserve((ClientData) interp); TclFormatInt(portBuf, port); - Tcl_RegisterChannel(interp, chan); - - /* - * Artificially bump the refcount to protect the channel from - * being deleted while the script is being evaluated. - */ - - Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); - - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, (char *) NULL); - if (result != TCL_OK) { - Tcl_BackgroundError(interp); + Tcl_RegisterChannel(interp, chan); + + /* + * Artificially bump the refcount to protect the channel from being + * deleted while the script is being evaluated. + */ + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); + + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, (char *) NULL); + if (result != TCL_OK) { + Tcl_BackgroundError(interp); Tcl_UnregisterChannel(interp, chan); - } + } - /* - * Decrement the artificially bumped refcount. After this it is - * not safe anymore to use "chan", because it may now be deleted. - */ + /* + * Decrement the artificially bumped refcount. After this it is not + * safe anymore to use "chan", because it may now be deleted. + */ - Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); - - Tcl_Release((ClientData) interp); - Tcl_Release((ClientData) script); + Tcl_UnregisterChannel((Tcl_Interp *) NULL, chan); + + Tcl_Release((ClientData) interp); + Tcl_Release((ClientData) script); } else { - /* - * The interpreter has been deleted, so there is no useful - * way to utilize the client socket - just close it. - */ + /* + * The interpreter has been deleted, so there is no useful way to + * utilize the client socket - just close it. + */ - Tcl_Close((Tcl_Interp *) NULL, chan); + Tcl_Close((Tcl_Interp *) NULL, chan); } } @@ -1238,18 +1243,18 @@ AcceptCallbackProc(callbackData, chan, address, port) * * TcpServerCloseProc -- * - * This callback is called when the TCP server channel for which it - * was registered is being closed. It informs the interpreter in - * which the accept script is evaluated (if that interpreter still - * exists) that this channel no longer needs to be informed if the - * interpreter is deleted. + * This callback is called when the TCP server channel for which it was + * registered is being closed. It informs the interpreter in which the + * accept script is evaluated (if that interpreter still exists) that + * this channel no longer needs to be informed if the interpreter is + * deleted. * * Results: * None. * * Side effects: - * In the future, if the interpreter is deleted this channel will - * no longer be informed. + * In the future, if the interpreter is deleted this channel will no + * longer be informed. * *---------------------------------------------------------------------- */ @@ -1257,15 +1262,15 @@ AcceptCallbackProc(callbackData, chan, address, port) static void TcpServerCloseProc(callbackData) ClientData callbackData; /* The data passed in the call to - * Tcl_CreateCloseHandler. */ + * Tcl_CreateCloseHandler. */ { AcceptCallback *acceptCallbackPtr; - /* The actual data. */ + /* The actual data. */ acceptCallbackPtr = (AcceptCallback *) callbackData; if (acceptCallbackPtr->interp != (Tcl_Interp *) NULL) { - UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, - acceptCallbackPtr); + UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, + acceptCallbackPtr); } Tcl_EventuallyFree((ClientData) acceptCallbackPtr->script, TCL_DYNAMIC); ckfree((char *) acceptCallbackPtr); @@ -1276,8 +1281,8 @@ TcpServerCloseProc(callbackData) * * Tcl_SocketObjCmd -- * - * This procedure is invoked to process the "socket" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "socket" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -1299,7 +1304,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) "-async", "-myaddr", "-myport","-server", (char *) NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; int optionIndex, a, server, port; char *arg, *copyScript, *host, *script; @@ -1308,7 +1313,7 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) int async = 0; Tcl_Channel chan; AcceptCallback *acceptCallbackPtr; - + server = 0; script = NULL; @@ -1326,68 +1331,61 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) return TCL_ERROR; } switch ((enum socketOptions) optionIndex) { - case SKT_ASYNC: { - if (server == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - async = 1; - break; + case SKT_ASYNC: + if (server == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; } - case SKT_MYADDR: { - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myaddr option", - (char *) NULL); - return TCL_ERROR; - } - myaddr = Tcl_GetString(objv[a]); - break; + async = 1; + break; + case SKT_MYADDR: + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myaddr option", (char *) NULL); + return TCL_ERROR; } - case SKT_MYPORT: { - char *myPortName; - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -myport option", - (char *) NULL); - return TCL_ERROR; - } - myPortName = Tcl_GetString(objv[a]); - if (TclSockGetPort(interp, myPortName, "tcp", &myport) - != TCL_OK) { - return TCL_ERROR; - } - break; + myaddr = Tcl_GetString(objv[a]); + break; + case SKT_MYPORT: { + char *myPortName; + + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -myport option", (char *) NULL); + return TCL_ERROR; } - case SKT_SERVER: { - if (async == 1) { - Tcl_AppendResult(interp, - "cannot set -async option for server sockets", - (char *) NULL); - return TCL_ERROR; - } - server = 1; - a++; - if (a >= objc) { - Tcl_AppendResult(interp, - "no argument given for -server option", - (char *) NULL); - return TCL_ERROR; - } - script = Tcl_GetString(objv[a]); - break; + myPortName = Tcl_GetString(objv[a]); + if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) { + return TCL_ERROR; } - default: { - Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); + break; + } + case SKT_SERVER: + if (async == 1) { + Tcl_AppendResult(interp, + "cannot set -async option for server sockets", + (char *) NULL); + return TCL_ERROR; + } + server = 1; + a++; + if (a >= objc) { + Tcl_AppendResult(interp, + "no argument given for -server option", (char *) NULL); + return TCL_ERROR; } + script = Tcl_GetString(objv[a]); + break; + default: + Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); } } if (server) { - host = myaddr; /* NULL implies INADDR_ANY */ + host = myaddr; /* NULL implies INADDR_ANY */ if (myport != 0) { Tcl_AppendResult(interp, "Option -myport is not valid for servers", NULL); @@ -1397,19 +1395,21 @@ Tcl_SocketObjCmd(notUsed, interp, objc, objv) host = Tcl_GetString(objv[a]); a++; } else { -wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args: should be either:\n", - Tcl_GetString(objv[0]), - " ?-myaddr addr? ?-myport myport? ?-async? host port\n", - Tcl_GetString(objv[0]), - " -server command ?-myaddr addr? port", - (char *) NULL); - return TCL_ERROR; + Interp *iPtr; + + wrongNumArgs: + Tcl_WrongNumArgs(interp, 1, objv, + "?-myaddr addr? ?-myport myport? ?-async? host port"); + iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; + Tcl_WrongNumArgs(interp, 1, objv, + "-server command ?-myaddr addr? port"); + iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; + return TCL_ERROR; } if (a == objc-1) { - if (TclSockGetPort(interp, Tcl_GetString(objv[a]), - "tcp", &port) != TCL_OK) { + if (TclSockGetPort(interp, Tcl_GetString(objv[a]), "tcp", + &port) != TCL_OK) { return TCL_ERROR; } } else { @@ -1417,46 +1417,46 @@ wrongNumArgs: } if (server) { - acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) - sizeof(AcceptCallback)); - copyScript = ckalloc((unsigned) strlen(script) + 1); - strcpy(copyScript, script); - acceptCallbackPtr->script = copyScript; - acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - (ClientData) acceptCallbackPtr); - if (chan == (Tcl_Channel) NULL) { - ckfree(copyScript); - ckfree((char *) acceptCallbackPtr); - return TCL_ERROR; - } - - /* - * Register with the interpreter to let us know when the - * interpreter is deleted (by having the callback set the - * acceptCallbackPtr->interp field to NULL). This is to - * avoid trying to eval the script in a deleted interpreter. - */ - - RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); - - /* - * Register a close callback. This callback will inform the - * interpreter (if it still exists) that this channel does not - * need to be informed when the interpreter is deleted. - */ - - Tcl_CreateCloseHandler(chan, TcpServerCloseProc, - (ClientData) acceptCallbackPtr); + acceptCallbackPtr = (AcceptCallback *) ckalloc((unsigned) + sizeof(AcceptCallback)); + copyScript = ckalloc((unsigned) strlen(script) + 1); + strcpy(copyScript, script); + acceptCallbackPtr->script = copyScript; + acceptCallbackPtr->interp = interp; + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + (ClientData) acceptCallbackPtr); + if (chan == (Tcl_Channel) NULL) { + ckfree(copyScript); + ckfree((char *) acceptCallbackPtr); + return TCL_ERROR; + } + + /* + * Register with the interpreter to let us know when the interpreter + * is deleted (by having the callback set the interp field of the + * acceptCallbackPtr's structure to NULL). This is to avoid trying to + * eval the script in a deleted interpreter. + */ + + RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr); + + /* + * Register a close callback. This callback will inform the + * interpreter (if it still exists) that this channel does not need to + * be informed when the interpreter is deleted. + */ + + Tcl_CreateCloseHandler(chan, TcpServerCloseProc, + (ClientData) acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } } - Tcl_RegisterChannel(interp, chan); + Tcl_RegisterChannel(interp, chan); Tcl_AppendResult(interp, Tcl_GetChannelName(chan), (char *) NULL); - + return TCL_OK; } @@ -1465,15 +1465,15 @@ wrongNumArgs: * * Tcl_FcopyObjCmd -- * - * This procedure is invoked to process the "fcopy" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "fcopy" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Moves data between two channels and possibly sets up a - * background copy handler. + * Moves data between two channels and possibly sets up a background copy + * handler. * *---------------------------------------------------------------------- */ @@ -1500,8 +1500,8 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) } /* - * Parse the channel arguments and verify that they are readable - * or writable, as appropriate. + * Parse the channel arguments and verify that they are readable or + * writable, as appropriate. */ arg = Tcl_GetString(objv[1]); @@ -1510,9 +1510,9 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_READABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for reading", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for reading", (char *) NULL); + return TCL_ERROR; } arg = Tcl_GetString(objv[2]); outChan = Tcl_GetChannel(interp, arg, &mode); @@ -1520,9 +1520,9 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } if ((mode & TCL_WRITABLE) == 0) { - Tcl_AppendResult(interp, "channel \"", arg, - "\" wasn't opened for writing", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "channel \"", arg, + "\" wasn't opened for writing", (char *) NULL); + return TCL_ERROR; } toRead = -1; @@ -1533,14 +1533,14 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv) return TCL_ERROR; } switch (index) { - case FcopySize: - if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { - return TCL_ERROR; - } - break; - case FcopyCommand: - cmdPtr = objv[i+1]; - break; + case FcopySize: + if (Tcl_GetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) { + return TCL_ERROR; + } + break; + case FcopyCommand: + cmdPtr = objv[i+1]; + break; } } @@ -1590,6 +1590,7 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) /* * User is supplying an explicit length. */ + if (Tcl_GetWideIntFromObj(interp, objv[2], &length) != TCL_OK) { return TCL_ERROR; } @@ -1602,6 +1603,7 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) /* * User wants to truncate to the current file position. */ + length = Tcl_Tell(chan); if (length == Tcl_WideAsLong(-1)) { Tcl_AppendResult(interp, @@ -1619,3 +1621,11 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 57f9ed2..48419da 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -10,104 +10,102 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * CVS: $Id: tclIOGT.c,v 1.12 2004/11/13 00:19:09 dgp Exp $ + * CVS: $Id: tclIOGT.c,v 1.13 2005/07/17 21:17:41 dkf Exp $ */ #include "tclInt.h" #include "tclIO.h" - /* - * Forward declarations of internal procedures. - * First the driver procedures of the transformation. + * Forward declarations of internal procedures. First the driver procedures + * of the transformation. */ -static int TransformBlockModeProc _ANSI_ARGS_ (( - ClientData instanceData, int mode)); -static int TransformCloseProc _ANSI_ARGS_ (( - ClientData instanceData, Tcl_Interp* interp)); -static int TransformInputProc _ANSI_ARGS_ (( - ClientData instanceData, - char* buf, int toRead, int* errorCodePtr)); -static int TransformOutputProc _ANSI_ARGS_ (( - ClientData instanceData, CONST char *buf, - int toWrite, int* errorCodePtr)); -static int TransformSeekProc _ANSI_ARGS_ (( - ClientData instanceData, long offset, - int mode, int* errorCodePtr)); +static int TransformBlockModeProc _ANSI_ARGS_(( + ClientData instanceData, int mode)); +static int TransformCloseProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_Interp* interp)); +static int TransformInputProc _ANSI_ARGS_(( + ClientData instanceData, char *buf, int toRead, + int *errorCodePtr)); +static int TransformOutputProc _ANSI_ARGS_(( + ClientData instanceData, CONST char *buf, + int toWrite, int *errorCodePtr)); +static int TransformSeekProc _ANSI_ARGS_(( + ClientData instanceData, long offset, int mode, + int *errorCodePtr)); static int TransformSetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, CONST char *value)); + ClientData instanceData, Tcl_Interp *interp, + CONST char *optionName, CONST char *value)); static int TransformGetOptionProc _ANSI_ARGS_(( - ClientData instanceData, Tcl_Interp *interp, - CONST char *optionName, Tcl_DString *dsPtr)); -static void TransformWatchProc _ANSI_ARGS_ (( - ClientData instanceData, int mask)); -static int TransformGetFileHandleProc _ANSI_ARGS_ (( - ClientData instanceData, int direction, - ClientData* handlePtr)); -static int TransformNotifyProc _ANSI_ARGS_ (( - ClientData instanceData, int mask)); -static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_ (( - ClientData instanceData, Tcl_WideInt offset, - int mode, int* errorCodePtr)); + ClientData instanceData, Tcl_Interp *interp, + CONST char *optionName, Tcl_DString *dsPtr)); +static void TransformWatchProc _ANSI_ARGS_(( + ClientData instanceData, int mask)); +static int TransformGetFileHandleProc _ANSI_ARGS_(( + ClientData instanceData, int direction, + ClientData *handlePtr)); +static int TransformNotifyProc _ANSI_ARGS_(( + ClientData instanceData, int mask)); +static Tcl_WideInt TransformWideSeekProc _ANSI_ARGS_(( + ClientData instanceData, Tcl_WideInt offset, + int mode, int *errorCodePtr)); /* - * Forward declarations of internal procedures. - * Secondly the procedures for handling and generating fileeevents. + * Forward declarations of internal procedures. Secondly the procedures for + * handling and generating fileeevents. */ -static void TransformChannelHandlerTimer _ANSI_ARGS_ (( - ClientData clientData)); +static void TransformChannelHandlerTimer _ANSI_ARGS_(( + ClientData clientData)); /* - * Forward declarations of internal procedures. - * Third, helper procedures encapsulating essential tasks. + * Forward declarations of internal procedures. Third, helper procedures + * encapsulating essential tasks. */ typedef struct TransformChannelData TransformChannelData; -static int ExecuteCallback _ANSI_ARGS_ (( - TransformChannelData* ctrl, Tcl_Interp* interp, - unsigned char* op, unsigned char* buf, - int bufLen, int transmit, int preserve)); +static int ExecuteCallback _ANSI_ARGS_(( + TransformChannelData *ctrl, Tcl_Interp *interp, + unsigned char *op, unsigned char *buf, int bufLen, + int transmit, int preserve)); /* - * Action codes to give to 'ExecuteCallback' (argument 'transmit') - * confering to the procedure what to do with the result of the script - * it calls. + * Action codes to give to 'ExecuteCallback' (argument 'transmit') confering + * to the procedure what to do with the result of the script it calls. */ -#define TRANSMIT_DONT (0) /* No transfer to do */ -#define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */ -#define TRANSMIT_SELF (2) /* Transfer into our channel. */ -#define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */ -#define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */ +#define TRANSMIT_DONT (0) /* No transfer to do */ +#define TRANSMIT_DOWN (1) /* Transfer to the underlying channel */ +#define TRANSMIT_SELF (2) /* Transfer into our channel. */ +#define TRANSMIT_IBUF (3) /* Transfer to internal input buffer */ +#define TRANSMIT_NUM (4) /* Transfer number to 'maxRead' */ /* * Codes for 'preserve' of 'ExecuteCallback' */ -#define P_PRESERVE (1) -#define P_NO_PRESERVE (0) +#define P_PRESERVE (1) +#define P_NO_PRESERVE (0) /* - * Strings for the action codes delivered to the script implementing - * a transformation. Argument 'op' of 'ExecuteCallback'. + * Strings for the action codes delivered to the script implementing a + * transformation. Argument 'op' of 'ExecuteCallback'. */ -#define A_CREATE_WRITE (UCHARP ("create/write")) -#define A_DELETE_WRITE (UCHARP ("delete/write")) -#define A_FLUSH_WRITE (UCHARP ("flush/write")) -#define A_WRITE (UCHARP ("write")) +#define A_CREATE_WRITE (UCHARP("create/write")) +#define A_DELETE_WRITE (UCHARP("delete/write")) +#define A_FLUSH_WRITE (UCHARP("flush/write")) +#define A_WRITE (UCHARP("write")) -#define A_CREATE_READ (UCHARP ("create/read")) -#define A_DELETE_READ (UCHARP ("delete/read")) -#define A_FLUSH_READ (UCHARP ("flush/read")) -#define A_READ (UCHARP ("read")) +#define A_CREATE_READ (UCHARP("create/read")) +#define A_DELETE_READ (UCHARP("delete/read")) +#define A_FLUSH_READ (UCHARP("flush/read")) +#define A_READ (UCHARP("read")) -#define A_QUERY_MAXREAD (UCHARP ("query/maxRead")) -#define A_CLEAR_READ (UCHARP ("clear/read")) +#define A_QUERY_MAXREAD (UCHARP("query/maxRead")) +#define A_CLEAR_READ (UCHARP("clear/read")) /* * Management of a simple buffer. @@ -115,16 +113,16 @@ static int ExecuteCallback _ANSI_ARGS_ (( typedef struct ResultBuffer ResultBuffer; -static void ResultClear _ANSI_ARGS_ ((ResultBuffer* r)); -static void ResultInit _ANSI_ARGS_ ((ResultBuffer* r)); -static int ResultLength _ANSI_ARGS_ ((ResultBuffer* r)); -static int ResultCopy _ANSI_ARGS_ ((ResultBuffer* r, - unsigned char* buf, int toRead)); -static void ResultAdd _ANSI_ARGS_ ((ResultBuffer* r, - unsigned char* buf, int toWrite)); +static void ResultClear _ANSI_ARGS_((ResultBuffer *r)); +static void ResultInit _ANSI_ARGS_((ResultBuffer *r)); +static int ResultLength _ANSI_ARGS_((ResultBuffer *r)); +static int ResultCopy _ANSI_ARGS_((ResultBuffer *r, + unsigned char *buf, int toRead)); +static void ResultAdd _ANSI_ARGS_((ResultBuffer *r, + unsigned char *buf, int toWrite)); /* - * This structure describes the channel type structure for tcl based + * This structure describes the channel type structure for Tcl based * transformations. */ @@ -158,30 +156,31 @@ static Tcl_ChannelType transformChannelType = { */ struct ResultBuffer { - unsigned char* buf; /* Reference to the buffer area */ - int allocated; /* Allocated size of the buffer area */ - int used; /* Number of bytes in the buffer, <= allocated */ + unsigned char *buf; /* Reference to the buffer area. */ + int allocated; /* Allocated size of the buffer area. */ + int used; /* Number of bytes in the buffer, <= + * allocated. */ }; /* * Additional bytes to allocate during buffer expansion */ -#define INCREMENT (512) +#define INCREMENT (512) /* - * Number of milliseconds to wait before firing an event to flush - * out information waiting in buffers (fileevent support). + * Number of milliseconds to wait before firing an event to flush out + * information waiting in buffers (fileevent support). */ -#define FLUSH_DELAY (5) +#define FLUSH_DELAY (5) /* * Convenience macro to make some casts easier to use. */ -#define UCHARP(x) ((unsigned char*) (x)) -#define NO_INTERP ((Tcl_Interp*) NULL) +#define UCHARP(x) ((unsigned char *) (x)) +#define NO_INTERP ((Tcl_Interp *) NULL) /* * Definition of a structure used by all transformations generated here to @@ -189,48 +188,47 @@ struct ResultBuffer { */ struct TransformChannelData { - /* * General section. Data to integrate the transformation into the channel * system. */ - Tcl_Channel self; /* Our own Channel handle */ - int readIsFlushed; /* Flag to note wether in.flushProc was called or not - */ - int flags; /* Currently CHANNEL_ASYNC or zero */ - int watchMask; /* Current watch/event/interest mask */ - int mode; /* mode of parent channel, OR'ed combination of - * TCL_READABLE, TCL_WRITABLE */ - Tcl_TimerToken timer; /* Timer for automatic flushing of information - * sitting in an internal buffer. Required for full - * fileevent support */ + Tcl_Channel self; /* Our own Channel handle. */ + int readIsFlushed; /* Flag to note whether in.flushProc was + * called or not. */ + int flags; /* Currently CHANNEL_ASYNC or zero. */ + int watchMask; /* Current watch/event/interest mask. */ + int mode; /* Mode of parent channel, OR'ed combination + * of TCL_READABLE, TCL_WRITABLE. */ + Tcl_TimerToken timer; /* Timer for automatic flushing of information + * sitting in an internal buffer. Required for + * full fileevent support. */ + /* * Transformation specific data. */ - int maxRead; /* Maximum allowed number of bytes to read, as - * given to us by the tcl script implementing the - * transformation. */ - Tcl_Interp* interp; /* Reference to the interpreter which created the - * transformation. Used to execute the code - * below. */ - Tcl_Obj* command; /* Tcl code to execute for a buffer */ - ResultBuffer result; /* Internal buffer used to store the result of a - * transformation of incoming data. Additionally - * serves as buffer of all data not yet consumed by - * the reader. */ + int maxRead; /* Maximum allowed number of bytes to read, as + * given to us by the tcl script implementing + * the transformation. */ + Tcl_Interp *interp; /* Reference to the interpreter which created + * the transformation. Used to execute the + * code below. */ + Tcl_Obj *command; /* Tcl code to execute for a buffer */ + ResultBuffer result; /* Internal buffer used to store the result of + * a transformation of incoming data. + * Additionally serves as buffer of all data + * not yet consumed by the reader. */ }; - /* *---------------------------------------------------------------------- * * TclChannelTransform -- * - * Implements the Tcl "testchannel transform" debugging command. - * This is part of the testing environment. This sets up a tcl - * script (cmdObjPtr) to be used as a transform on the channel. + * Implements the Tcl "testchannel transform" debugging command. This is + * part of the testing environment. This sets up a tcl script (cmdObjPtr) + * to be used as a transform on the channel. * * Results: * A standard Tcl result. @@ -248,30 +246,29 @@ TclChannelTransform(interp, chan, cmdObjPtr) Tcl_Channel chan; /* Channel to transform. */ Tcl_Obj *cmdObjPtr; /* Script to use for transform. */ { - Channel *chanPtr; /* The actual channel. */ - ChannelState *statePtr; /* state info for channel */ - int mode; /* rw mode of the channel */ - TransformChannelData *dataPtr; - int res; - Tcl_DString ds; + Channel *chanPtr; /* The actual channel. */ + ChannelState *statePtr; /* state info for channel */ + int mode; /* rw mode of the channel */ + TransformChannelData *dataPtr; + int res; + Tcl_DString ds; if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - chanPtr = (Channel *) chan; - statePtr = chanPtr->state; - chanPtr = statePtr->topChanPtr; - chan = (Tcl_Channel) chanPtr; - mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE)); + chanPtr = (Channel *) chan; + statePtr = chanPtr->state; + chanPtr = statePtr->topChanPtr; + chan = (Tcl_Channel) chanPtr; + mode = (statePtr->flags & (TCL_READABLE|TCL_WRITABLE)); /* - * Now initialize the transformation state and stack it upon the - * specified channel. One of the necessary things to do is to - * retrieve the blocking regime of the underlying channel and to - * use the same for us too. + * Now initialize the transformation state and stack it upon the specified + * channel. One of the necessary things to do is to retrieve the blocking + * regime of the underlying channel and to use the same for us too. */ - dataPtr = (TransformChannelData*) ckalloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData)); Tcl_DStringInit (&ds); Tcl_GetChannelOption(interp, chan, "-blocking", &ds); @@ -283,15 +280,15 @@ TclChannelTransform(interp, chan, cmdObjPtr) dataPtr->flags |= CHANNEL_ASYNC; } - Tcl_DStringFree (&ds); + Tcl_DStringFree(&ds); - dataPtr->self = chan; - dataPtr->watchMask = 0; - dataPtr->mode = mode; - dataPtr->timer = (Tcl_TimerToken) NULL; - dataPtr->maxRead = 4096; /* Initial value not relevant */ - dataPtr->interp = interp; - dataPtr->command = cmdObjPtr; + dataPtr->self = chan; + dataPtr->watchMask = 0; + dataPtr->mode = mode; + dataPtr->timer = (Tcl_TimerToken) NULL; + dataPtr->maxRead = 4096; /* Initial value not relevant */ + dataPtr->interp = interp; + dataPtr->command = cmdObjPtr; Tcl_IncrRefCount(dataPtr->command); @@ -305,7 +302,7 @@ TclChannelTransform(interp, chan, cmdObjPtr) Tcl_DecrRefCount(dataPtr->command); ResultClear(&dataPtr->result); - ckfree((VOID *) dataPtr); + ckfree((char *) dataPtr); return TCL_ERROR; } @@ -314,8 +311,8 @@ TclChannelTransform(interp, chan, cmdObjPtr) */ if (dataPtr->mode & TCL_WRITABLE) { - res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_WRITE, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_WRITE, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { Tcl_UnstackChannel(interp, chan); @@ -324,12 +321,12 @@ TclChannelTransform(interp, chan, cmdObjPtr) } if (dataPtr->mode & TCL_READABLE) { - res = ExecuteCallback (dataPtr, NO_INTERP, A_CREATE_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_CREATE_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); if (res != TCL_OK) { - ExecuteCallback (dataPtr, NO_INTERP, A_DELETE_WRITE, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_DELETE_WRITE, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); Tcl_UnstackChannel(interp, chan); return TCL_ERROR; @@ -340,37 +337,36 @@ TclChannelTransform(interp, chan, cmdObjPtr) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ExecuteCallback -- + * ExecuteCallback -- * - * Executes the defined callback for buffer and - * operation. + * Executes the defined callback for buffer and operation. * - * Sideeffects: - * As of the executed tcl script. + * Side effects: + * As of the executed tcl script. * - * Result: - * A standard TCL error code. In case of an - * error a message is left in the result area - * of the specified interpreter. + * Result: + * A standard TCL error code. In case of an error a message is left in + * the result area of the specified interpreter. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) - TransformChannelData* dataPtr; /* Transformation with the callback */ - Tcl_Interp* interp; /* Current interpreter, possibly NULL */ - unsigned char* op; /* Operation invoking the callback */ - unsigned char* buf; /* Buffer to give to the script. */ - int bufLen; /* Ands its length */ - int transmit; /* Flag, determines whether the result - * of the callback is sent to the - * underlying channel or not. */ - int preserve; /* Flag. If true the procedure will - * preserver the result state of all - * accessed interpreters. */ +ExecuteCallback(dataPtr, interp, op, buf, bufLen, transmit, preserve) + TransformChannelData *dataPtr; /* Transformation with the callback */ + Tcl_Interp *interp; /* Current interpreter, possibly + * NULL. */ + unsigned char *op; /* Operation invoking the callback */ + unsigned char *buf; /* Buffer to give to the script. */ + int bufLen; /* And its length */ + int transmit; /* Flag, determines whether the result + * of the callback is sent to the + * underlying channel or not. */ + int preserve; /* Flag. If true the procedure will + * preserver the result state of all + * accessed interpreters. */ { /* * Step 1, create the complete command to execute. Do this by appending @@ -380,13 +376,13 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) * arguments. Feather's curried commands would come in handy here. */ - Tcl_Obj* resObj; /* See below, switch (transmit) */ + Tcl_Obj *resObj; /* See below, switch (transmit) */ int resLen; - unsigned char* resBuf; + unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; - Tcl_Obj* command = Tcl_DuplicateObj (dataPtr->command); - Tcl_Obj* temp; + Tcl_Obj *command = Tcl_DuplicateObj(dataPtr->command); + Tcl_Obj *temp; if (preserve) { state = Tcl_SaveInterpState(dataPtr->interp, res); @@ -414,8 +410,8 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) } /* - * Use a byte-array to prevent the misinterpretation of binary data - * coming through as UTF while at the tcl level. + * Use a byte-array to prevent the misinterpretation of binary data coming + * through as UTF while at the tcl level. */ temp = Tcl_NewByteArrayObj(buf, bufLen); @@ -426,21 +422,21 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) goto cleanup; } - res = Tcl_ListObjAppendElement (dataPtr->interp, command, temp); + res = Tcl_ListObjAppendElement(dataPtr->interp, command, temp); if (res != TCL_OK) { goto cleanup; } /* - * Step 2, execute the command at the global level of the interpreter - * used to create the transformation. Destroy the command afterward. - * If an error occured and the current interpreter is defined and not - * equal to the interpreter for the callback, then copy the error - * message into current interpreter. Don't copy if in preservation mode. + * Step 2, execute the command at the global level of the interpreter used + * to create the transformation. Destroy the command afterward. If an + * error occured and the current interpreter is defined and not equal to + * the interpreter for the callback, then copy the error message into + * current interpreter. Don't copy if in preservation mode. */ - res = Tcl_GlobalEvalObj (dataPtr->interp, command); - Tcl_DecrRefCount (command); + res = Tcl_GlobalEvalObj(dataPtr->interp, command); + Tcl_DecrRefCount(command); command = (Tcl_Obj*) NULL; if ((res != TCL_OK) && (interp != NO_INTERP) && @@ -455,34 +451,34 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) */ switch (transmit) { - case TRANSMIT_DONT: - /* nothing to do */ - break; - - case TRANSMIT_DOWN: - resObj = Tcl_GetObjResult(dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), - (char*) resBuf, resLen); - break; - - case TRANSMIT_SELF: - resObj = Tcl_GetObjResult (dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - Tcl_WriteRaw(dataPtr->self, (char*) resBuf, resLen); - break; - - case TRANSMIT_IBUF: - resObj = Tcl_GetObjResult (dataPtr->interp); - resBuf = (unsigned char*) Tcl_GetByteArrayFromObj(resObj, &resLen); - ResultAdd(&dataPtr->result, resBuf, resLen); - break; - - case TRANSMIT_NUM: - /* Interpret result as integer number */ - resObj = Tcl_GetObjResult (dataPtr->interp); - Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); - break; + case TRANSMIT_DONT: + /* nothing to do */ + break; + + case TRANSMIT_DOWN: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, + resLen); + break; + + case TRANSMIT_SELF: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; + + case TRANSMIT_IBUF: + resObj = Tcl_GetObjResult(dataPtr->interp); + resBuf = (unsigned char *) Tcl_GetByteArrayFromObj(resObj, &resLen); + ResultAdd(&dataPtr->result, resBuf, resLen); + break; + + case TRANSMIT_NUM: + /* Interpret result as integer number */ + resObj = Tcl_GetObjResult(dataPtr->interp); + Tcl_GetIntFromObj(dataPtr->interp, resObj, &dataPtr->maxRead); + break; } Tcl_ResetResult(dataPtr->interp); @@ -493,7 +489,7 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) return res; - cleanup: + cleanup: if (preserve) { (void) Tcl_RestoreInterpState(dataPtr->interp, state); } @@ -506,30 +502,28 @@ ExecuteCallback (dataPtr, interp, op, buf, bufLen, transmit, preserve) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformBlockModeProc -- + * TransformBlockModeProc -- * - * Trap handler. Called by the generic IO system - * during option processing to change the blocking - * mode of the channel. + * Trap handler. Called by the generic IO system during option processing + * to change the blocking mode of the channel. * - * Sideeffects: - * Forwards the request to the underlying - * channel. + * Side effects: + * Forwards the request to the underlying channel. * - * Result: - * 0 if successful, errno when failed. + * Result: + * 0 if successful, errno when failed. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformBlockModeProc (instanceData, mode) - ClientData instanceData; /* State of transformation */ - int mode; /* New blocking mode */ +TransformBlockModeProc(instanceData, mode) + ClientData instanceData; /* State of transformation */ + int mode; /* New blocking mode */ { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; if (mode == TCL_MODE_NONBLOCKING) { dataPtr->flags |= CHANNEL_ASYNC; @@ -540,33 +534,32 @@ TransformBlockModeProc (instanceData, mode) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformCloseProc -- + * TransformCloseProc -- * - * Trap handler. Called by the generic IO system - * during destruction of the transformation channel. + * Trap handler. Called by the generic IO system during destruction of + * the transformation channel. * - * Sideeffects: - * Releases the memory allocated in - * 'Tcl_TransformObjCmd'. + * Side effects: + * Releases the memory allocated in 'Tcl_TransformObjCmd'. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformCloseProc (instanceData, interp) - ClientData instanceData; - Tcl_Interp* interp; +TransformCloseProc(instanceData, interp) + ClientData instanceData; + Tcl_Interp *interp; { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; /* - * Important: In this procedure 'dataPtr->self' already points to - * the underlying channel. + * Important: In this procedure 'dataPtr->self' already points to the + * underlying channel. */ /* @@ -579,36 +572,36 @@ TransformCloseProc (instanceData, interp) */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } /* * Now flush data waiting in internal buffers to output and input. The - * input must be done despite the fact that there is no real receiver - * for it anymore. But the scripts might have sideeffects other parts - * of the system rely on (f.e. signaling the close to interested parties). + * input must be done despite the fact that there is no real receiver for + * it anymore. But the scripts might have sideeffects other parts of the + * system rely on (f.e. signaling the close to interested parties). */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, interp, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, 1); + ExecuteCallback(dataPtr, interp, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, 1); } if ((dataPtr->mode & TCL_READABLE) && !dataPtr->readIsFlushed) { dataPtr->readIsFlushed = 1; - ExecuteCallback (dataPtr, interp, A_FLUSH_READ, - NULL, 0, TRANSMIT_IBUF, 1); + ExecuteCallback(dataPtr, interp, A_FLUSH_READ, NULL, 0, + TRANSMIT_IBUF, 1); } if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, interp, A_DELETE_WRITE, - NULL, 0, TRANSMIT_DONT, 1); + ExecuteCallback(dataPtr, interp, A_DELETE_WRITE, NULL, 0, + TRANSMIT_DONT, 1); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, interp, A_DELETE_READ, - NULL, 0, TRANSMIT_DONT, 1); + ExecuteCallback(dataPtr, interp, A_DELETE_READ, NULL, 0, + TRANSMIT_DONT, 1); } /* @@ -617,42 +610,43 @@ TransformCloseProc (instanceData, interp) ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - ckfree((VOID*) dataPtr); + ckfree((char *) dataPtr); return TCL_OK; } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformInputProc -- + * TransformInputProc -- * * Called by the generic IO system to convert read data. * - * Sideeffects: - * As defined by the conversion. + * Side effects: + * As defined by the conversion. * - * Result: - * A transformed buffer. + * Result: + * A transformed buffer. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformInputProc (instanceData, buf, toRead, errorCodePtr) +TransformInputProc(instanceData, buf, toRead, errorCodePtr) ClientData instanceData; - char* buf; - int toRead; - int* errorCodePtr; + char *buf; + int toRead; + int *errorCodePtr; { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData* dataPtr = (TransformChannelData *) instanceData; int gotBytes, read, res, copied; Tcl_Channel downChan; /* should assert (dataPtr->mode & TCL_READABLE) */ if (toRead == 0) { - /* Catch a no-op. + /* + * Catch a no-op. */ return 0; } @@ -666,33 +660,34 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) * below, possibly EOF). */ - copied = ResultCopy (&dataPtr->result, UCHARP (buf), toRead); + copied = ResultCopy(&dataPtr->result, UCHARP(buf), toRead); - toRead -= copied; - buf += copied; + toRead -= copied; + buf += copied; gotBytes += copied; if (toRead == 0) { - /* The request was completely satisfied from our buffers. - * We can break out of the loop and return to the caller. + /* + * The request was completely satisfied from our buffers. We can + * break out of the loop and return to the caller. */ return gotBytes; } /* - * Length (dataPtr->result) == 0, toRead > 0 here . Use the incoming - * 'buf'! as target to store the intermediary information read - * from the underlying channel. + * Length (dataPtr->result) == 0, toRead > 0 here. Use the incoming + * 'buf'! as target to store the intermediary information read from + * the underlying channel. * - * Ask the tcl level how much data it allows us to read from - * the underlying channel. This feature allows the transform to - * signal EOF upstream although there is none downstream. Useful - * to control an unbounded 'fcopy', either through counting bytes, - * or by pattern matching. + * Ask the tcl level how much data it allows us to read from the + * underlying channel. This feature allows the transform to signal EOF + * upstream although there is none downstream. Useful to control an + * unbounded 'fcopy', either through counting bytes, or by pattern + * matching. */ - ExecuteCallback (dataPtr, NO_INTERP, A_QUERY_MAXREAD, - NULL, 0, TRANSMIT_NUM /* -> maxRead */, 1); + ExecuteCallback(dataPtr, NO_INTERP, A_QUERY_MAXREAD, NULL, 0, + TRANSMIT_NUM /* -> maxRead */, 1); if (dataPtr->maxRead >= 0) { if (dataPtr->maxRead < toRead) { @@ -707,9 +702,10 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) read = Tcl_ReadRaw(downChan, buf, toRead); if (read < 0) { - /* Report errors to caller. EAGAIN is a special situation. - * If we had some data before we report that instead of the - * request to re-try. + /* + * Report errors to caller. EAGAIN is a special situation. If we + * had some data before we report that instead of the request to + * re-try. */ if ((Tcl_GetErrno() == EAGAIN) && (gotBytes > 0)) { @@ -722,17 +718,16 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) if (read == 0) { /* - * Check wether we hit on EOF in the underlying channel or - * not. If not differentiate between blocking and - * non-blocking modes. In non-blocking mode we ran - * temporarily out of data. Signal this to the caller via - * EWOULDBLOCK and error return (-1). In the other cases - * we simply return what we got and let the caller wait - * for more. On the other hand, if we got an EOF we have - * to convert and flush all waiting partial data. + * Check wether we hit on EOF in the underlying channel or not. If + * not differentiate between blocking and non-blocking modes. In + * non-blocking mode we ran temporarily out of data. Signal this + * to the caller via EWOULDBLOCK and error return (-1). In the + * other cases we simply return what we got and let the caller + * wait for more. On the other hand, if we got an EOF we have to + * convert and flush all waiting partial data. */ - if (! Tcl_Eof (downChan)) { + if (! Tcl_Eof(downChan)) { if ((gotBytes == 0) && (dataPtr->flags & CHANNEL_ASYNC)) { *errorCodePtr = EWOULDBLOCK; return -1; @@ -741,17 +736,18 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) } } else { if (dataPtr->readIsFlushed) { - /* Already flushed, nothing to do anymore + /* + * Already flushed, nothing to do anymore. */ return gotBytes; } dataPtr->readIsFlushed = 1; - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_READ, - NULL, 0, TRANSMIT_IBUF, P_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_READ, NULL, 0, + TRANSMIT_IBUF, P_PRESERVE); - if (ResultLength (&dataPtr->result) == 0) { + if (ResultLength(&dataPtr->result) == 0) { /* we had nothing to flush */ return gotBytes; } @@ -760,12 +756,13 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) } } /* read == 0 */ - /* Transform the read chunk and add the result to our - * read buffer (dataPtr->result) + /* + * Transform the read chunk and add the result to our read buffer + * (dataPtr->result) */ - res = ExecuteCallback (dataPtr, NO_INTERP, A_READ, - UCHARP (buf), read, TRANSMIT_IBUF, P_PRESERVE); + res = ExecuteCallback(dataPtr, NO_INTERP, A_READ, UCHARP(buf), read, + TRANSMIT_IBUF, P_PRESERVE); if (res != TCL_OK) { *errorCodePtr = EINVAL; @@ -777,28 +774,27 @@ TransformInputProc (instanceData, buf, toRead, errorCodePtr) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformOutputProc -- + * TransformOutputProc -- * - * Called by the generic IO system to convert data - * waiting to be written. + * Called by the generic IO system to convert data waiting to be written. * - * Sideeffects: - * As defined by the transformation. + * Side effects: + * As defined by the transformation. * - * Result: - * A transformed buffer. + * Result: + * A transformed buffer. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) +TransformOutputProc(instanceData, buf, toWrite, errorCodePtr) ClientData instanceData; - CONST char* buf; - int toWrite; - int* errorCodePtr; + CONST char *buf; + int toWrite; + int *errorCodePtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; int res; @@ -806,13 +802,13 @@ TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) /* should assert (dataPtr->mode & TCL_WRITABLE) */ if (toWrite == 0) { - /* Catch a no-op. + /* + * Catch a no-op. */ return 0; } - res = ExecuteCallback (dataPtr, NO_INTERP, A_WRITE, - UCHARP (buf), toWrite, + res = ExecuteCallback(dataPtr, NO_INTERP, A_WRITE, UCHARP(buf), toWrite, TRANSMIT_DOWN, P_NO_PRESERVE); if (res != TCL_OK) { @@ -824,42 +820,40 @@ TransformOutputProc (instanceData, buf, toWrite, errorCodePtr) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformSeekProc -- + * TransformSeekProc -- * - * This procedure is called by the generic IO level - * to move the access point in a channel. + * This procedure is called by the generic IO level to move the access + * point in a channel. * - * Sideeffects: - * Moves the location at which the channel - * will be accessed in future operations. - * Flushes all transformation buffers, then - * forwards it to the underlying channel. + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. * - * Result: - * -1 if failed, the new position if - * successful. An output argument contains - * the POSIX error code if an error - * occurred, or zero. + * Result: + * -1 if failed, the new position if successful. An output argument + * contains the POSIX error code if an error occurred, or zero. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ - long offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ +TransformSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* The channel to manipulate */ + long offset; /* Size of movement. */ + int mode; /* How to move */ + int *errorCodePtr; /* Location of error flag. */ { - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; - Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); - Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); - Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType); + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); if ((offset == 0) && (mode == SEEK_CUR)) { - /* This is no seek but a request to tell the caller the current + /* + * This is no seek but a request to tell the caller the current * location. Simply pass the request down. */ @@ -868,19 +862,19 @@ TransformSeekProc (instanceData, offset, mode, errorCodePtr) } /* - * It is a real request to change the position. Flush all data waiting - * for output and discard everything in the input buffers. Then pass - * the request down, unchanged. + * It is a real request to change the position. Flush all data waiting for + * output and discard everything in the input buffers. Then pass the + * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } @@ -894,41 +888,35 @@ TransformSeekProc (instanceData, offset, mode, errorCodePtr) * * TransformWideSeekProc -- * - * This procedure is called by the generic IO level to move the - * access point in a channel, with a (potentially) 64-bit offset. + * This procedure is called by the generic IO level to move the access + * point in a channel, with a (potentially) 64-bit offset. * * Side effects: - * Moves the location at which the channel will be accessed in - * future operations. Flushes all transformation buffers, then - * forwards it to the underlying channel. + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. * * Result: - * -1 if failed, the new position if successful. An output - * argument contains the POSIX error code if an error occurred, - * or zero. + * -1 if failed, the new position if successful. An output argument + * contains the POSIX error code if an error occurred, or zero. * *---------------------------------------------------------------------- */ static Tcl_WideInt -TransformWideSeekProc (instanceData, offset, mode, errorCodePtr) - ClientData instanceData; /* The channel to manipulate */ +TransformWideSeekProc(instanceData, offset, mode, errorCodePtr) + ClientData instanceData; /* The channel to manipulate */ Tcl_WideInt offset; /* Size of movement. */ - int mode; /* How to move */ - int* errorCodePtr; /* Location of error flag. */ + int mode; /* How to move */ + int *errorCodePtr; /* Location of error flag. */ { - TransformChannelData* dataPtr = - (TransformChannelData*) instanceData; - Tcl_Channel parent = - Tcl_GetStackedChannel(dataPtr->self); - Tcl_ChannelType* parentType = - Tcl_GetChannelType(parent); - Tcl_DriverSeekProc* parentSeekProc = - Tcl_ChannelSeekProc(parentType); + TransformChannelData * dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + Tcl_ChannelType* parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc* parentSeekProc = Tcl_ChannelSeekProc(parentType); Tcl_DriverWideSeekProc* parentWideSeekProc = - Tcl_ChannelWideSeekProc(parentType); - ClientData parentData = - Tcl_GetChannelInstanceData(parent); + Tcl_ChannelWideSeekProc(parentType); + ClientData parentData = Tcl_GetChannelInstanceData(parent); if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { /* @@ -946,19 +934,19 @@ TransformWideSeekProc (instanceData, offset, mode, errorCodePtr) } /* - * It is a real request to change the position. Flush all data waiting - * for output and discard everything in the input buffers. Then pass - * the request down, unchanged. + * It is a real request to change the position. Flush all data waiting for + * output and discard everything in the input buffers. Then pass the + * request down, unchanged. */ if (dataPtr->mode & TCL_WRITABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_FLUSH_WRITE, - NULL, 0, TRANSMIT_DOWN, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_FLUSH_WRITE, NULL, 0, + TRANSMIT_DOWN, P_NO_PRESERVE); } if (dataPtr->mode & TCL_READABLE) { - ExecuteCallback (dataPtr, NO_INTERP, A_CLEAR_READ, - NULL, 0, TRANSMIT_DONT, P_NO_PRESERVE); + ExecuteCallback(dataPtr, NO_INTERP, A_CLEAR_READ, NULL, 0, + TRANSMIT_DONT, P_NO_PRESERVE); ResultClear(&dataPtr->result); dataPtr->readIsFlushed = 0; } @@ -966,46 +954,48 @@ TransformWideSeekProc (instanceData, offset, mode, errorCodePtr) /* * If we have a wide seek capability, we should stick with that. */ + if (parentWideSeekProc != NULL) { return (*parentWideSeekProc) (parentData, offset, mode, errorCodePtr); } /* - * We're transferring to narrow seeks at this point; this is a bit - * complex because we have to check whether the seek is possible - * first (i.e. whether we are losing information in truncating the - * bits of the offset.) Luckily, there's a defined error for what - * happens when trying to go out of the representable range. + * We're transferring to narrow seeks at this point; this is a bit complex + * because we have to check whether the seek is possible first (i.e. + * whether we are losing information in truncating the bits of the + * offset.) Luckily, there's a defined error for what happens when trying + * to go out of the representable range. */ + if (offsetTcl_LongAsWide(LONG_MAX)) { *errorCodePtr = EOVERFLOW; return Tcl_LongAsWide(-1); } + return Tcl_LongAsWide((*parentSeekProc) (parentData, Tcl_WideAsLong(offset), mode, errorCodePtr)); } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformSetOptionProc -- + * TransformSetOptionProc -- * - * Called by generic layer to handle the reconfi- - * guration of channel specific options. As this - * channel type does not have such, it simply passes - * all requests downstream. + * Called by generic layer to handle the reconfiguration of channel + * specific options. As this channel type does not have such, it simply + * passes all requests downstream. * - * Sideeffects: - * As defined by the channel downstream. + * Side effects: + * As defined by the channel downstream. * - * Result: - * A standard TCL error code. + * Result: + * A standard TCL error code. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformSetOptionProc (instanceData, interp, optionName, value) +TransformSetOptionProc(instanceData, interp, optionName, value) ClientData instanceData; Tcl_Interp *interp; CONST char *optionName; @@ -1024,30 +1014,29 @@ TransformSetOptionProc (instanceData, interp, optionName, value) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformGetOptionProc -- + * TransformGetOptionProc -- * - * Called by generic layer to handle requests for - * the values of channel specific options. As this - * channel type does not have such, it simply passes - * all requests downstream. + * Called by generic layer to handle requests for the values of channel + * specific options. As this channel type does not have such, it simply + * passes all requests downstream. * - * Sideeffects: - * As defined by the channel downstream. + * Side effects: + * As defined by the channel downstream. * - * Result: - * A standard TCL error code. + * Result: + * A standard TCL error code. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformGetOptionProc (instanceData, interp, optionName, dsPtr) - ClientData instanceData; - Tcl_Interp* interp; - CONST char* optionName; - Tcl_DString* dsPtr; +TransformGetOptionProc(instanceData, interp, optionName, dsPtr) + ClientData instanceData; + Tcl_Interp *interp; + CONST char *optionName; + Tcl_DString *dsPtr; { TransformChannelData* dataPtr = (TransformChannelData*) instanceData; Tcl_Channel downChan = Tcl_GetStackedChannel(dataPtr->self); @@ -1061,165 +1050,166 @@ TransformGetOptionProc (instanceData, interp, optionName, dsPtr) /* * Request is query for all options, this is ok. */ + return TCL_OK; } + /* * Request for a specific option has to fail, we don't have any. */ + return TCL_ERROR; } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformWatchProc -- + * TransformWatchProc -- * - * Initialize the notifier to watch for events from - * this channel. + * Initialize the notifier to watch for events from this channel. * - * Sideeffects: - * Sets up the notifier so that a future - * event on the channel will be seen by Tcl. + * Side effects: + * Sets up the notifier so that a future event on the channel will be + * seen by Tcl. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ + /* ARGSUSED */ static void -TransformWatchProc (instanceData, mask) +TransformWatchProc(instanceData, mask) ClientData instanceData; /* Channel to watch */ - int mask; /* Events of interest */ + int mask; /* Events of interest */ { - /* The caller expressed interest in events occuring for this - * channel. We are forwarding the call to the underlying - * channel now. + /* + * The caller expressed interest in events occuring for this channel. We + * are forwarding the call to the underlying channel now. */ - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; - Tcl_Channel downChan; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; + Tcl_Channel downChan; dataPtr->watchMask = mask; - /* No channel handlers any more. We will be notified automatically - * about events on the channel below via a call to our - * 'TransformNotifyProc'. But we have to pass the interest down now. - * We are allowed to add additional 'interest' to the mask if we want - * to. But this transformation has no such interest. It just passes - * the request down, unchanged. + /* + * No channel handlers any more. We will be notified automatically about + * events on the channel below via a call to our 'TransformNotifyProc'. + * But we have to pass the interest down now. We are allowed to add + * additional 'interest' to the mask if we want to. But this + * transformation has no such interest. It just passes the request down, + * unchanged. */ downChan = Tcl_GetStackedChannel(dataPtr->self); - (Tcl_GetChannelType(downChan)) - ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + Tcl_GetChannelType(downChan)->watchProc( + Tcl_GetChannelInstanceData(downChan), mask); /* * Management of the internal timer. */ if ((dataPtr->timer != (Tcl_TimerToken) NULL) && - (!(mask & TCL_READABLE) || (ResultLength(&dataPtr->result) == 0))) { - - /* A pending timer exists, but either is there no (more) - * interest in the events it generates or nothing is availablee - * for reading, so remove it. + (!(mask & TCL_READABLE) || ResultLength(&dataPtr->result)==0)) { + /* + * A pending timer exists, but either is there no (more) interest in + * the events it generates or nothing is availablee for reading, so + * remove it. */ - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } if ((dataPtr->timer == (Tcl_TimerToken) NULL) && - (mask & TCL_READABLE) && (ResultLength (&dataPtr->result) > 0)) { - - /* There is no pending timer, but there is interest in readable - * events and we actually have data waiting, so generate a timer - * to flush that. + (mask & TCL_READABLE) && (ResultLength(&dataPtr->result) > 0)) { + /* + * There is no pending timer, but there is interest in readable events + * and we actually have data waiting, so generate a timer to flush + * that. */ - dataPtr->timer = Tcl_CreateTimerHandler (FLUSH_DELAY, + dataPtr->timer = Tcl_CreateTimerHandler(FLUSH_DELAY, TransformChannelHandlerTimer, (ClientData) dataPtr); } } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformGetFileHandleProc -- + * TransformGetFileHandleProc -- * - * Called from Tcl_GetChannelHandle to retrieve - * OS specific file handle from inside this channel. + * Called from Tcl_GetChannelHandle to retrieve OS specific file handle + * from inside this channel. * - * Sideeffects: - * None. + * Side effects: + * None. * - * Result: - * The appropriate Tcl_File or NULL if not - * present. + * Result: + * The appropriate Tcl_File or NULL if not present. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ + static int -TransformGetFileHandleProc (instanceData, direction, handlePtr) - ClientData instanceData; /* Channel to query */ - int direction; /* Direction of interest */ - ClientData* handlePtr; /* Place to store the handle into */ +TransformGetFileHandleProc(instanceData, direction, handlePtr) + ClientData instanceData; /* Channel to query */ + int direction; /* Direction of interest */ + ClientData *handlePtr; /* Place to store the handle into */ { /* - * Return the handle belonging to parent channel. - * IOW, pass the request down and the result up. + * Return the handle belonging to parent channel. IOW, pass the request + * down and the result up. */ - TransformChannelData* dataPtr = (TransformChannelData*) instanceData; + TransformChannelData *dataPtr = (TransformChannelData *) instanceData; return Tcl_GetChannelHandle(Tcl_GetStackedChannel(dataPtr->self), direction, handlePtr); } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformNotifyProc -- + * TransformNotifyProc -- * - * ------------------------------------------------* - * Handler called by Tcl to inform us of activity - * on the underlying channel. - * ------------------------------------------------* + * Handler called by Tcl to inform us of activity on the underlying + * channel. * - * Sideeffects: - * May process the incoming event by itself. + * Side effects: + * May process the incoming event by itself. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -TransformNotifyProc (clientData, mask) - ClientData clientData; /* The state of the notified transformation */ - int mask; /* The mask of occuring events */ +TransformNotifyProc(clientData, mask) + ClientData clientData; /* The state of the notified transformation */ + int mask; /* The mask of occuring events */ { - TransformChannelData* dataPtr = (TransformChannelData*) clientData; + TransformChannelData *dataPtr = (TransformChannelData *) clientData; /* - * An event occured in the underlying channel. This - * transformation doesn't process such events thus returns the - * incoming mask unchanged. + * An event occured in the underlying channel. This transformation + * doesn't process such events thus returns the incoming mask unchanged. */ if (dataPtr->timer != (Tcl_TimerToken) NULL) { /* - * Delete an existing timer. It was not fired, yet we are - * here, so the channel below generated such an event and we - * don't have to. The renewal of the interest after the - * execution of channel handlers will eventually cause us to - * recreate the timer (in TransformWatchProc). + * Delete an existing timer. It was not fired, yet we are here, so the + * channel below generated such an event and we don't have to. The + * renewal of the interest after the execution of channel handlers + * will eventually cause us to recreate the timer (in + * TransformWatchProc). */ - Tcl_DeleteTimerHandler (dataPtr->timer); + Tcl_DeleteTimerHandler(dataPtr->timer); dataPtr->timer = (Tcl_TimerToken) NULL; } @@ -1227,35 +1217,36 @@ TransformNotifyProc (clientData, mask) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * TransformChannelHandlerTimer -- + * TransformChannelHandlerTimer -- * - * Called by the notifier (-> timer) to flush out - * information waiting in the input buffer. + * Called by the notifier (-> timer) to flush out information waiting in + * the input buffer. * - * Sideeffects: - * As of 'Tcl_NotifyChannel'. + * Side effects: + * As of 'Tcl_NotifyChannel'. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static void -TransformChannelHandlerTimer (clientData) - ClientData clientData; /* Transformation to query */ +TransformChannelHandlerTimer(clientData) + ClientData clientData; /* Transformation to query */ { - TransformChannelData* dataPtr = (TransformChannelData*) clientData; + TransformChannelData *dataPtr = (TransformChannelData *) clientData; dataPtr->timer = (Tcl_TimerToken) NULL; if (!(dataPtr->watchMask & TCL_READABLE) || - (ResultLength (&dataPtr->result) == 0)) { - /* The timer fired, but either is there no (more) - * interest in the events it generates or nothing is available - * for reading, so ignore it and don't recreate it. + (ResultLength(&dataPtr->result) == 0)) { + /* + * The timer fired, but either is there no (more) interest in the + * events it generates or nothing is available for reading, so ignore + * it and don't recreate it. */ return; @@ -1265,183 +1256,183 @@ TransformChannelHandlerTimer (clientData) } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ResultClear -- + * ResultClear -- * * Deallocates any memory allocated by 'ResultAdd'. * - * Sideeffects: - * See above. + * Side effects: + * See above. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static void -ResultClear (r) - ResultBuffer* r; /* Reference to the buffer to clear out */ +ResultClear(r) + ResultBuffer *r; /* Reference to the buffer to clear out. */ { r->used = 0; if (r->allocated) { - ckfree((char*) r->buf); - r->buf = UCHARP (NULL); + ckfree((char *) r->buf); + r->buf = UCHARP(NULL); r->allocated = 0; } } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ResultInit -- + * ResultInit -- * - * Initializes the specified buffer structure. The - * structure will contain valid information for an - * emtpy buffer. + * Initializes the specified buffer structure. The structure will contain + * valid information for an emtpy buffer. * - * Sideeffects: - * See above. + * Side effects: + * See above. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static void -ResultInit (r) - ResultBuffer* r; /* Reference to the structure to initialize */ +ResultInit(r) + ResultBuffer *r; /* Reference to the structure to initialize */ { - r->used = 0; + r->used = 0; r->allocated = 0; - r->buf = UCHARP (NULL); + r->buf = UCHARP(NULL); } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ResultLength -- + * ResultLength -- * * Returns the number of bytes stored in the buffer. * - * Sideeffects: - * None. + * Side effects: + * None. * - * Result: - * An integer, see above too. + * Result: + * An integer, see above too. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -ResultLength (r) - ResultBuffer* r; /* The structure to query */ +ResultLength(r) + ResultBuffer *r; /* The structure to query */ { return r->used; } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ResultCopy -- + * ResultCopy -- * - * Copies the requested number of bytes from the - * buffer into the specified array and removes them - * from the buffer afterward. Copies less if there - * is not enough data in the buffer. + * Copies the requested number of bytes from the buffer into the + * specified array and removes them from the buffer afterward. Copies + * less if there is not enough data in the buffer. * - * Sideeffects: - * See above. + * Side effects: + * See above. * - * Result: - * The number of actually copied bytes, - * possibly less than 'toRead'. + * Result: + * The number of actually copied bytes, possibly less than 'toRead'. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static int -ResultCopy (r, buf, toRead) - ResultBuffer* r; /* The buffer to read from */ - unsigned char* buf; /* The buffer to copy into */ - int toRead; /* Number of requested bytes */ +ResultCopy(r, buf, toRead) + ResultBuffer *r; /* The buffer to read from. */ + unsigned char *buf; /* The buffer to copy into. */ + int toRead; /* Number of requested bytes. */ { if (r->used == 0) { - /* Nothing to copy in the case of an empty buffer. + /* + * Nothing to copy in the case of an empty buffer. */ return 0; } if (r->used == toRead) { - /* We have just enough. Copy everything to the caller. + /* + * We have just enough. Copy everything to the caller. */ - memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead); + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); r->used = 0; return toRead; } if (r->used > toRead) { - /* The internal buffer contains more than requested. - * Copy the requested subset to the caller, and shift - * the remaining bytes down. + /* + * The internal buffer contains more than requested. Copy the + * requested subset to the caller, and shift the remaining bytes down. */ - memcpy ((VOID*) buf, (VOID*) r->buf, (size_t) toRead); - memmove ((VOID*) r->buf, (VOID*) (r->buf + toRead), + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) toRead); + memmove((VOID *) r->buf, (VOID *) (r->buf + toRead), (size_t) r->used - toRead); r->used -= toRead; return toRead; } - /* There is not enough in the buffer to satisfy the caller, so - * take everything. + /* + * There is not enough in the buffer to satisfy the caller, so take + * everything. */ - memcpy((VOID*) buf, (VOID*) r->buf, (size_t) r->used); + memcpy((VOID *) buf, (VOID *) r->buf, (size_t) r->used); toRead = r->used; r->used = 0; return toRead; } /* - *------------------------------------------------------* + *---------------------------------------------------------------------- * - * ResultAdd -- + * ResultAdd -- * - * Adds the bytes in the specified array to the - * buffer, by appending it. + * Adds the bytes in the specified array to the buffer, by appending it. * - * Sideeffects: - * See above. + * Side effects: + * See above. * - * Result: - * None. + * Result: + * None. * - *------------------------------------------------------* + *---------------------------------------------------------------------- */ static void -ResultAdd (r, buf, toWrite) - ResultBuffer* r; /* The buffer to extend */ - unsigned char* buf; /* The buffer to read from */ - int toWrite; /* The number of bytes in 'buf' */ +ResultAdd(r, buf, toWrite) + ResultBuffer *r; /* The buffer to extend */ + unsigned char *buf; /* The buffer to read from */ + int toWrite; /* The number of bytes in 'buf' */ { if ((r->used + toWrite) > r->allocated) { - /* Extension of the internal buffer is required. + /* + * Extension of the internal buffer is required. */ if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = UCHARP (ckalloc((unsigned) r->allocated)); + r->buf = UCHARP(ckalloc((unsigned) r->allocated)); } else { r->allocated += toWrite + INCREMENT; - r->buf = UCHARP (ckrealloc((char*) r->buf, + r->buf = UCHARP(ckrealloc((char *) r->buf, (unsigned) r->allocated)); } } @@ -1450,3 +1441,11 @@ ResultAdd (r, buf, toWrite) memcpy(r->buf + r->used, buf, (size_t) toWrite); r->used += toWrite; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 8dfd7f5..da0fc8f 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1,28 +1,28 @@ -/* +/* * tclIOUtil.c -- * - * This file contains the implementation of Tcl's generic - * filesystem code, which supports a pluggable filesystem - * architecture allowing both platform specific filesystems and - * 'virtual filesystems'. All filesystem access should go through - * the functions defined in this file. Most of this code was - * contributed by Vince Darley. + * This file contains the implementation of Tcl's generic filesystem + * code, which supports a pluggable filesystem architecture allowing both + * platform specific filesystems and 'virtual filesystems'. All + * filesystem access should go through the functions defined in this + * file. Most of this code was contributed by Vince Darley. * - * Parts of this file are based on code contributed by Karl - * Lehenbauer, Mark Diekhans and Peter da Silva. + * Parts of this file are based on code contributed by Karl Lehenbauer, + * Mark Diekhans and Peter da Silva. * * Copyright (c) 1991-1994 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2001-2004 Vincent Darley. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.119 2005/05/23 20:19:44 das Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.120 2005/07/17 21:17:42 dkf Exp $ */ #include "tclInt.h" #ifdef __WIN32__ -#include "tclWinInt.h" +# include "tclWinInt.h" #endif #include "tclFileSystem.h" @@ -32,32 +32,32 @@ static FilesystemRecord * FsGetFirstFilesystem _ANSI_ARGS_((void)); static void FsThrExitProc _ANSI_ARGS_((ClientData cd)); -static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, +static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, CONST char *pattern)); static void FsAddMountsToGlobResult _ANSI_ARGS_(( Tcl_Obj *resultPtr, Tcl_Obj *pathPtr, - CONST char *pattern, + CONST char *pattern, Tcl_GlobTypeData *types)); -static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, +static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj, ClientData clientData)); #ifdef TCL_THREADS static void FsRecacheFilesystemList(void); #endif -/* - * These form part of the native filesystem support. They are needed - * here because we have a few native filesystem functions (which are - * the same for win/unix) in this file. There is no need to place - * them in tclInt.h, because they are not (and should not be) used - * anywhere else. +/* + * These form part of the native filesystem support. They are needed here + * because we have a few native filesystem functions (which are the same for + * win/unix) in this file. There is no need to place them in tclInt.h, + * because they are not (and should not be) used anywhere else. */ + extern CONST char * tclpFileAttrStrings[]; extern CONST TclFileAttrProcs tclpFileAttrProcs[]; -/* - * The following functions are obsolete string based APIs, and should - * be removed in a future release (Tcl 9 would be a good time). +/* + * The following functions are obsolete string based APIs, and should be + * removed in a future release (Tcl 9 would be a good time). */ /* Obsolete */ @@ -87,7 +87,7 @@ Tcl_Stat(path, oldStyleBuf) * Note that ino_t/ino64_t is unsigned... */ - if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) + if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) #ifdef HAVE_ST_BLOCKS || OUT_OF_RANGE(buf.st_blocks) #endif @@ -109,27 +109,27 @@ Tcl_Stat(path, oldStyleBuf) #endif /* !TCL_WIDE_INT_IS_LONG */ /* - * Copy across all supported fields, with possible type - * coercions on those fields that change between the normal - * and lf64 versions of the stat structure (on Solaris at - * least.) This is slow when the structure sizes coincide, - * but that's what you get for using an obsolete interface. + * Copy across all supported fields, with possible type coercions on + * those fields that change between the normal and lf64 versions of + * the stat structure (on Solaris at least.) This is slow when the + * structure sizes coincide, but that's what you get for using an + * obsolete interface. */ - oldStyleBuf->st_mode = buf.st_mode; - oldStyleBuf->st_ino = (ino_t) buf.st_ino; - oldStyleBuf->st_dev = buf.st_dev; - oldStyleBuf->st_rdev = buf.st_rdev; - oldStyleBuf->st_nlink = buf.st_nlink; - oldStyleBuf->st_uid = buf.st_uid; - oldStyleBuf->st_gid = buf.st_gid; - oldStyleBuf->st_size = (off_t) buf.st_size; - oldStyleBuf->st_atime = buf.st_atime; - oldStyleBuf->st_mtime = buf.st_mtime; - oldStyleBuf->st_ctime = buf.st_ctime; + oldStyleBuf->st_mode = buf.st_mode; + oldStyleBuf->st_ino = (ino_t) buf.st_ino; + oldStyleBuf->st_dev = buf.st_dev; + oldStyleBuf->st_rdev = buf.st_rdev; + oldStyleBuf->st_nlink = buf.st_nlink; + oldStyleBuf->st_uid = buf.st_uid; + oldStyleBuf->st_gid = buf.st_gid; + oldStyleBuf->st_size = (off_t) buf.st_size; + oldStyleBuf->st_atime = buf.st_atime; + oldStyleBuf->st_mtime = buf.st_mtime; + oldStyleBuf->st_ctime = buf.st_ctime; #ifdef HAVE_ST_BLOCKS - oldStyleBuf->st_blksize = buf.st_blksize; - oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; + oldStyleBuf->st_blksize = buf.st_blksize; + oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; #endif } return ret; @@ -139,35 +139,37 @@ Tcl_Stat(path, oldStyleBuf) int Tcl_Access(path, mode) CONST char *path; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ + int mode; /* Permission setting. */ { int ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSAccess(pathPtr,mode); Tcl_DecrRefCount(pathPtr); + return ret; } /* Obsolete */ Tcl_Channel Tcl_OpenFileChannel(interp, path, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - CONST char *path; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ + Tcl_Interp *interp; /* Interpreter for error reporting; can be + * NULL. */ + CONST char *path; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions; /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Channel ret; Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); + Tcl_IncrRefCount(pathPtr); ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); Tcl_DecrRefCount(pathPtr); - return ret; + return ret; } /* Obsolete */ @@ -216,28 +218,28 @@ Tcl_EvalFile(interp, fileName) return ret; } - -/* +/* * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The - * complete, general hooked filesystem APIs should be used instead. - * This define decides whether to include the obsolete hooks and - * related code. If these are removed, we'll also want to remove them - * from stubs/tclInt. The only known users of these APIs are prowrap - * and mktclapp. New code/extensions should not use them, since they - * do not provide as full support as the full filesystem API. - * - * As soon as prowrap and mktclapp are updated to use the full - * filesystem support, I suggest all these hooks are removed. + * complete, general hooked filesystem APIs should be used instead. This + * define decides whether to include the obsolete hooks and related code. If + * these are removed, we'll also want to remove them from stubs/tclInt. The + * only known users of these APIs are prowrap and mktclapp. New + * code/extensions should not use them, since they do not provide as full + * support as the full filesystem API. + * + * As soon as prowrap and mktclapp are updated to use the full filesystem + * support, I suggest all these hooks are removed. */ -#define USE_OBSOLETE_FS_HOOKS +#define USE_OBSOLETE_FS_HOOKS #ifdef USE_OBSOLETE_FS_HOOKS + /* - * The following typedef declarations allow for hooking into the chain - * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & - * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function - * a linked list is defined. + * The following typedef declarations allow for hooking into the chain of + * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked + * list is defined. */ typedef struct StatProc { @@ -251,24 +253,22 @@ typedef struct AccessProc { } AccessProc; typedef struct OpenFileChannelProc { - TclOpenFileChannelProc_ *proc; /* Function to process a - * 'Tcl_OpenFileChannel()' call */ + TclOpenFileChannelProc_ *proc; /* Function to process a + * 'Tcl_OpenFileChannel()' call */ struct OpenFileChannelProc *nextPtr; - /* The next 'Tcl_OpenFileChannel()' - * function to call */ + /* The next 'Tcl_OpenFileChannel()' + * function to call */ } OpenFileChannelProc; /* - * For each type of (obsolete) hookable function, a static node is - * declared to hold the function pointer for the "built-in" routine - * (e.g. 'TclpStat(...)') and the respective list is initialized as a - * pointer to that node. - * - * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that - * these statically declared list entry cannot be inadvertently removed. + * For each type of (obsolete) hookable function, a static node is declared to + * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)') + * and the respective list is initialized as a pointer to that node. * - * This method avoids the need to call any sort of "initialization" - * function. + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these + * statically declared list entry cannot be inadvertently removed. + * + * This method avoids the need to call any sort of "initialization" function. * * All three lists are protected by a global obsoleteFsHookMutex. */ @@ -281,60 +281,60 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex) #endif /* USE_OBSOLETE_FS_HOOKS */ -/* - * Declare the native filesystem support. These functions should - * be considered private to Tcl, and should really not be called - * directly by any code other than this file (i.e. neither by - * Tcl's core nor by extensions). Similarly, the old string-based - * Tclp... native filesystem functions should not be called. - * - * The correct API to use now is the Tcl_FS... set of functions, - * which ensure correct and complete virtual filesystem support. - * - * We cannot make all of these static, since some of them - * are implemented in the platform-specific directories. +/* + * Declare the native filesystem support. These functions should be + * considered private to Tcl, and should really not be called directly by any + * code other than this file (i.e. neither by Tcl's core nor by extensions). + * Similarly, the old string-based Tclp... native filesystem functions should + * not be called. + * + * The correct API to use now is the Tcl_FS... set of functions, which ensure + * correct and complete virtual filesystem support. + * + * We cannot make all of these static, since some of them are implemented in + * the platform-specific directories. */ + static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; -/* - * The only reason these functions are not static is that they - * are either called by code in the native (win/unix) directories - * or they are actually implemented in those directories. They - * should simply not be called by code outside Tcl's native - * filesystem core. i.e. they should be considered 'static' to - * Tcl's filesystem code (if we ever built the native filesystem - * support into a separate code library, this could actually be - * enforced). +/* + * The only reason these functions are not static is that they are either + * called by code in the native (win/unix) directories or they are actually + * implemented in those directories. They should simply not be called by code + * outside Tcl's native filesystem core i.e. they should be considered + * 'static' to Tcl's filesystem code (if we ever built the native filesystem + * support into a separate code library, this could actually be enforced). */ + Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; Tcl_FSStatProc TclpObjStat; -Tcl_FSAccessProc TclpObjAccess; -Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; -Tcl_FSChdirProc TclpObjChdir; -Tcl_FSLstatProc TclpObjLstat; -Tcl_FSCopyFileProc TclpObjCopyFile; -Tcl_FSDeleteFileProc TclpObjDeleteFile; -Tcl_FSRenameFileProc TclpObjRenameFile; -Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; -Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; -Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; -Tcl_FSUnloadFileProc TclpUnloadFile; -Tcl_FSLinkProc TclpObjLink; -Tcl_FSListVolumesProc TclpObjListVolumes; - -/* - * Define the native filesystem dispatch table. If necessary, it - * is ok to make this non-static, but it should only be accessed - * by the functions actually listed within it (or perhaps other - * helper functions of them). Anything which is not part of this - * 'native filesystem implementation' should not be delving inside - * here! +Tcl_FSAccessProc TclpObjAccess; +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; +Tcl_FSChdirProc TclpObjChdir; +Tcl_FSLstatProc TclpObjLstat; +Tcl_FSCopyFileProc TclpObjCopyFile; +Tcl_FSDeleteFileProc TclpObjDeleteFile; +Tcl_FSRenameFileProc TclpObjRenameFile; +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; +Tcl_FSUnloadFileProc TclpUnloadFile; +Tcl_FSLinkProc TclpObjLink; +Tcl_FSListVolumesProc TclpObjListVolumes; + +/* + * Define the native filesystem dispatch table. If necessary, it is ok to + * make this non-static, but it should only be accessed by the functions + * actually listed within it (or perhaps other helper functions of them). + * Anything which is not part of this 'native filesystem implementation' + * should not be delving inside here! */ + Tcl_Filesystem tclNativeFilesystem = { "native", sizeof(Tcl_Filesystem), @@ -362,11 +362,11 @@ Tcl_Filesystem tclNativeFilesystem = { &NativeFileAttrsGet, &NativeFileAttrsSet, &TclpObjCreateDirectory, - &TclpObjRemoveDirectory, + &TclpObjRemoveDirectory, &TclpObjDeleteFile, &TclpObjCopyFile, &TclpObjRenameFile, - &TclpObjCopyDirectory, + &TclpObjCopyDirectory, &TclpObjLstat, &TclpDlopen, /* Needs a cast since we're using version_2 */ @@ -374,15 +374,16 @@ Tcl_Filesystem tclNativeFilesystem = { &TclpObjChdir }; -/* - * Define the tail of the linked list. Note that for unconventional - * uses of Tcl without a native filesystem, we may in the future wish - * to modify the current approach of hard-coding the native filesystem - * in the lookup list 'filesystemList' below. - * - * We initialize the record so that it thinks one file uses it. This - * means it will never be freed. +/* + * Define the tail of the linked list. Note that for unconventional uses of + * Tcl without a native filesystem, we may in the future wish to modify the + * current approach of hard-coding the native filesystem in the lookup list + * 'filesystemList' below. + * + * We initialize the record so that it thinks one file uses it. This means it + * will never be freed. */ + static FilesystemRecord nativeFilesystemRecord = { NULL, &tclNativeFilesystem, @@ -390,26 +391,28 @@ static FilesystemRecord nativeFilesystemRecord = { NULL }; -/* - * This is incremented each time we modify the linked list of - * filesystems. Any time it changes, all cached filesystem - * representations are suspect and must be freed. - * For multithreading builds, change of the filesystem epoch +/* + * This is incremented each time we modify the linked list of filesystems. + * Any time it changes, all cached filesystem representations are suspect and + * must be freed. For multithreading builds, change of the filesystem epoch * will trigger cache cleanup in all threads. */ + static int theFilesystemEpoch = 0; /* - * Stores the linked list of filesystems. A 1:1 copy of this - * list is also maintained in the TSD for each thread. This - * is to avoid synchronization issues. + * Stores the linked list of filesystems. A 1:1 copy of this list is also + * maintained in the TSD for each thread. This is to avoid synchronization + * issues. */ + static FilesystemRecord *filesystemList = &nativeFilesystemRecord; TCL_DECLARE_MUTEX(filesystemMutex) -/* +/* * Used to implement Tcl_FSGetCwd in a file-system independent way. */ + static Tcl_Obj* cwdPathPtr = NULL; static int cwdPathEpoch = 0; static ClientData cwdClientData = NULL; @@ -417,45 +420,55 @@ TCL_DECLARE_MUTEX(cwdMutex) Tcl_ThreadDataKey tclFsDataKey; -/* - * Declare fallback support function and - * information for Tcl_FSLoadFile +/* + * Declare fallback support function and information for Tcl_FSLoadFile */ + static Tcl_FSUnloadFileProc FSUnloadTempFile; /* - * One of these structures is used each time we successfully load a - * file from a file system by way of making a temporary copy of the - * file on the native filesystem. We need to store both the actual - * unloadProc/clientData combination which was used, and the original - * and modified filenames, so that we can correctly undo the entire - * operation when we want to unload the code. + * One of these structures is used each time we successfully load a file from + * a file system by way of making a temporary copy of the file on the native + * filesystem. We need to store both the actual unloadProc/clientData + * combination which was used, and the original and modified filenames, so + * that we can correctly undo the entire operation when we want to unload the + * code. */ + typedef struct FsDivertLoad { Tcl_LoadHandle loadHandle; - Tcl_FSUnloadFileProc *unloadProcPtr; + Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; } FsDivertLoad; - -/* Now move on to the basic filesystem implementation */ + +/* + * Now move on to the basic filesystem implementation + */ static void FsThrExitProc(cd) ClientData cd; { - ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd; + ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; - /* Trash the cwd copy */ + /* + * Trash the cwd copy. + */ + if (tsdPtr->cwdPathPtr != NULL) { Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } - /* Trash the filesystems cache */ + + /* + * Trash the filesystems cache. + */ + fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; @@ -467,7 +480,7 @@ FsThrExitProc(cd) } int -TclFSCwdIsNative() +TclFSCwdIsNative() { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); @@ -483,23 +496,23 @@ TclFSCwdIsNative() * * TclFSCwdPointerEquals -- * - * Check whether the current working directory is equal to the - * path given. - * + * Check whether the current working directory is equal to the path + * given. + * * Results: * 1 (equal) or 0 (un-equal) as appropriate. * * Side effects: - * If the paths are equal, but are not the same object, this - * method will modify the given pathPtrPtr to refer to the same - * object. In this case the object pointed to by pathPtrPtr will - * have its refCount decremented, and it will be adjusted to - * point to the cwd (with a new refCount). + * If the paths are equal, but are not the same object, this method will + * modify the given pathPtrPtr to refer to the same object. In this case + * the object pointed to by pathPtrPtr will have its refCount + * decremented, and it will be adjusted to point to the cwd (with a new + * refCount). * *---------------------------------------------------------------------- */ -int +int TclFSCwdPointerEquals(pathPtrPtr) Tcl_Obj** pathPtrPtr; { @@ -514,12 +527,12 @@ TclFSCwdPointerEquals(pathPtrPtr) if (tsdPtr->cwdClientData != NULL) { NativeFreeInternalRep(tsdPtr->cwdClientData); } - if (cwdPathPtr == NULL) { - tsdPtr->cwdPathPtr = NULL; - } else { - tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); - Tcl_IncrRefCount(tsdPtr->cwdPathPtr); - } + if (cwdPathPtr == NULL) { + tsdPtr->cwdPathPtr = NULL; + } else { + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); + Tcl_IncrRefCount(tsdPtr->cwdPathPtr); + } if (cwdClientData == NULL) { tsdPtr->cwdClientData = NULL; } else { @@ -530,26 +543,28 @@ TclFSCwdPointerEquals(pathPtrPtr) Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } if (pathPtrPtr == NULL) { - return (tsdPtr->cwdPathPtr == NULL); + return (tsdPtr->cwdPathPtr == NULL); } - + if (tsdPtr->cwdPathPtr == *pathPtrPtr) { - return 1; + return 1; } else { int len1, len2; CONST char *str1, *str2; + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if (len1 == len2 && !strcmp(str1,str2)) { - /* - * They are equal, but different objects. Update so they - * will be the same object in the future. + /* + * They are equal, but different objects. Update so they will be + * the same object in the future. */ + Tcl_DecrRefCount(*pathPtrPtr); *pathPtrPtr = tsdPtr->cwdPathPtr; Tcl_IncrRefCount(*pathPtrPtr); @@ -567,10 +582,13 @@ FsRecacheFilesystemList(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; - /* Trash the current cache */ + /* + * Trash the current cache. + */ + fsRecPtr = tsdPtr->filesystemList; while (fsRecPtr != NULL) { - tmpFsRecPtr = fsRecPtr->nextPtr; + tmpFsRecPtr = fsRecPtr->nextPtr; if (--fsRecPtr->fileRefCount <= 0) { ckfree((char *)fsRecPtr); } @@ -579,22 +597,25 @@ FsRecacheFilesystemList(void) tsdPtr->filesystemList = NULL; /* - * Code below operates on shared data. We - * are already called under mutex lock so - * we can safely proceede. + * Code below operates on shared data. We are already called under mutex + * lock so we can safely proceede. + * + * Locate tail of the global filesystem list. */ - /* Locate tail of the global filesystem list */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr; fsRecPtr = fsRecPtr->nextPtr; } - /* Refill the cache honouring the order */ + /* + * Refill the cache honouring the order. + */ + fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; tmpFsRecPtr->prevPtr = NULL; @@ -605,9 +626,12 @@ FsRecacheFilesystemList(void) fsRecPtr = fsRecPtr->prevPtr; } - /* Make sure the above gets released on thread exit */ + /* + * Make sure the above gets released on thread exit. + */ + if (tsdPtr->initialized == 0) { - Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); tsdPtr->initialized = 1; } } @@ -634,21 +658,23 @@ FsGetFirstFilesystem(void) { } /* - * The epoch can be changed both by filesystems being added or - * removed and by env(HOME) changing. + * The epoch can be changed both by filesystems being added or removed and by + * env(HOME) changing. */ + int -TclFSEpochOk (filesystemEpoch) - int filesystemEpoch; +TclFSEpochOk(filesystemEpoch) + int filesystemEpoch; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); (void) FsGetFirstFilesystem(); return (filesystemEpoch == tsdPtr->filesystemEpoch); } -/* +/* * If non-NULL, clientData is owned by us and must be freed later. */ + static void FsUpdateCwd(cwdObj, clientData) Tcl_Obj *cwdObj; @@ -664,35 +690,41 @@ FsUpdateCwd(cwdObj, clientData) Tcl_MutexLock(&cwdMutex); if (cwdPathPtr != NULL) { - Tcl_DecrRefCount(cwdPathPtr); + Tcl_DecrRefCount(cwdPathPtr); } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); } + if (cwdObj == NULL) { cwdPathPtr = NULL; cwdClientData = NULL; } else { - /* This must be stored as string obj! */ - cwdPathPtr = Tcl_NewStringObj(str, len); + /* + * This must be stored as string obj! + */ + + cwdPathPtr = Tcl_NewStringObj(str, len); Tcl_IncrRefCount(cwdPathPtr); cwdClientData = TclNativeDupInternalRep(clientData); } + cwdPathEpoch++; tsdPtr->cwdPathEpoch = cwdPathEpoch; Tcl_MutexUnlock(&cwdMutex); if (tsdPtr->cwdPathPtr) { - Tcl_DecrRefCount(tsdPtr->cwdPathPtr); + Tcl_DecrRefCount(tsdPtr->cwdPathPtr); } if (tsdPtr->cwdClientData) { NativeFreeInternalRep(tsdPtr->cwdClientData); } + if (cwdObj == NULL) { tsdPtr->cwdPathPtr = NULL; tsdPtr->cwdClientData = NULL; } else { - tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); + tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); tsdPtr->cwdClientData = clientData; Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } @@ -705,10 +737,10 @@ FsUpdateCwd(cwdObj, clientData) * * Clean up the filesystem. After this, calls to all Tcl_FS... * functions will fail. - * - * We will later call TclResetFilesystem to restore the FS - * to a pristine state. - * + * + * We will later call TclResetFilesystem to restore the FS to a pristine + * state. + * * Results: * None. * @@ -723,42 +755,45 @@ TclFinalizeFilesystem() { FilesystemRecord *fsRecPtr; - /* - * Assumption that only one thread is active now. Otherwise - * we would need to put various mutexes around this code. + /* + * Assumption that only one thread is active now. Otherwise we would need + * to put various mutexes around this code. */ - + if (cwdPathPtr != NULL) { Tcl_DecrRefCount(cwdPathPtr); cwdPathPtr = NULL; - cwdPathEpoch = 0; + cwdPathEpoch = 0; } if (cwdClientData != NULL) { NativeFreeInternalRep(cwdClientData); cwdClientData = NULL; } - /* - * Remove all filesystems, freeing any allocated memory - * that is no longer needed + /* + * Remove all filesystems, freeing any allocated memory that is no longer + * needed */ fsRecPtr = filesystemList; while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - if (fsRecPtr->fileRefCount <= 0) { - /* The native filesystem is static, so we don't free it */ - if (fsRecPtr != &nativeFilesystemRecord) { - ckfree((char *)fsRecPtr); - } - } - fsRecPtr = tmpFsRecPtr; + if (fsRecPtr->fileRefCount <= 0) { + /* + * The native filesystem is static, so we don't free it. + */ + + if (fsRecPtr != &nativeFilesystemRecord) { + ckfree((char *)fsRecPtr); + } + } + fsRecPtr = tmpFsRecPtr; } filesystemList = NULL; /* - * Now filesystemList is NULL. This means that any attempt - * to use the filesystem is likely to fail. + * Now filesystemList is NULL. This means that any attempt to use the + * filesystem is likely to fail. */ statProcList = NULL; @@ -775,7 +810,7 @@ TclFinalizeFilesystem() * TclResetFilesystem -- * * Restore the filesystem to a pristine state. - * + * * Results: * None. * @@ -789,18 +824,18 @@ void TclResetFilesystem() { filesystemList = &nativeFilesystemRecord; - /* - * Note, at this point, I believe nativeFilesystemRecord -> - * fileRefCount should equal 1 and if not, we should try to track - * down the cause. + + /* + * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount + * should equal 1 and if not, we should try to track down the cause. */ - + #ifdef __WIN32__ - /* - * Cleans up the win32 API filesystem proc lookup table. This must - * happen very late in finalization so that deleting of copied - * dlls can occur. + /* + * Cleans up the win32 API filesystem proc lookup table. This must happen + * very late in finalization so that deleting of copied dlls can occur. */ + TclWinResetInterfaces(); #endif } @@ -810,36 +845,35 @@ TclResetFilesystem() * * Tcl_FSRegister -- * - * Insert the filesystem function table at the head of the list of - * functions which are used during calls to all file-system - * operations. The filesystem will be added even if it is - * already in the list. (You can use Tcl_FSData to - * check if it is in the list, provided the ClientData used was - * not NULL). - * - * Note that the filesystem handling is head-to-tail of the list. - * Each filesystem is asked in turn whether it can handle a - * particular request, _until_ one of them says 'yes'. At that - * point no further filesystems are asked. - * - * In particular this means if you want to add a diagnostic - * filesystem (which simply reports all fs activity), it must be - * at the head of the list: i.e. it must be the last registered. + * Insert the filesystem function table at the head of the list of + * functions which are used during calls to all file-system operations. + * The filesystem will be added even if it is already in the list. (You + * can use Tcl_FSData to check if it is in the list, provided the + * ClientData used was not NULL). + * + * Note that the filesystem handling is head-to-tail of the list. Each + * filesystem is asked in turn whether it can handle a particular + * request, until one of them says 'yes'. At that point no further + * filesystems are asked. + * + * In particular this means if you want to add a diagnostic filesystem + * (which simply reports all fs activity), it must be at the head of the + * list: i.e. it must be the last registered. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for filesystems. + * Memory allocated and modifies the link list for filesystems. * *---------------------------------------------------------------------- */ int Tcl_FSRegister(clientData, fsPtr) - ClientData clientData; /* Client specific data for this fs */ - Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ + ClientData clientData; /* Client specific data for this fs */ + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ { FilesystemRecord *newFilesystemPtr; @@ -851,38 +885,41 @@ Tcl_FSRegister(clientData, fsPtr) newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; - /* - * We start with a refCount of 1. If this drops to zero, then - * anyone is welcome to ckfree us. + + /* + * We start with a refCount of 1. If this drops to zero, then anyone is + * welcome to ckfree us. */ + newFilesystemPtr->fileRefCount = 1; - /* - * Is this lock and wait strictly speaking necessary? Since any - * iterators out there will have grabbed a copy of the head of - * the list and be iterating away from that, if we add a new - * element to the head of the list, it can't possibly have any - * effect on any of their loops. In fact it could be better not - * to wait, since we are adjusting the filesystem epoch, any - * cached representations calculated by existing iterators are + /* + * Is this lock and wait strictly speaking necessary? Since any iterators + * out there will have grabbed a copy of the head of the list and be + * iterating away from that, if we add a new element to the head of the + * list, it can't possibly have any effect on any of their loops. In fact + * it could be better not to wait, since we are adjusting the filesystem + * epoch, any cached representations calculated by existing iterators are * going to have to be thrown away anyway. - * - * However, since registering and unregistering filesystems is - * a very rare action, this is not a very important point. + * + * However, since registering and unregistering filesystems is a very rare + * action, this is not a very important point. */ + Tcl_MutexLock(&filesystemMutex); newFilesystemPtr->nextPtr = filesystemList; newFilesystemPtr->prevPtr = NULL; if (filesystemList) { - filesystemList->prevPtr = newFilesystemPtr; + filesystemList->prevPtr = newFilesystemPtr; } filesystemList = newFilesystemPtr; - /* - * Increment the filesystem epoch counter, since existing paths - * might conceivably now belong to different filesystems. + /* + * Increment the filesystem epoch counter, since existing paths might + * conceivably now belong to different filesystems. */ + theFilesystemEpoch++; Tcl_MutexUnlock(&filesystemMutex); @@ -894,29 +931,28 @@ Tcl_FSRegister(clientData, fsPtr) * * Tcl_FSUnregister -- * - * Remove the passed filesystem from the list of filesystem - * function tables. It also ensures that the built-in - * (native) filesystem is not removable, although we may wish - * to change that decision in the future to allow a smaller - * Tcl core, in which the native filesystem is not used at - * all (we could, say, initialise Tcl completely over a network - * connection). + * Remove the passed filesystem from the list of filesystem function + * tables. It also ensures that the built-in (native) filesystem is not + * removable, although we may wish to change that decision in the future + * to allow a smaller Tcl core, in which the native filesystem is not + * used at all (we could, say, initialise Tcl completely over a network + * connection). * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory may be deallocated (or will be later, once no "path" - * objects refer to this filesystem), but the list of registered - * filesystems is updated immediately. + * Memory may be deallocated (or will be later, once no "path" objects + * refer to this filesystem), but the list of registered filesystems is + * updated immediately. * *---------------------------------------------------------------------- */ int Tcl_FSUnregister(fsPtr) - Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -924,9 +960,9 @@ Tcl_FSUnregister(fsPtr) Tcl_MutexLock(&filesystemMutex); /* - * Traverse the 'filesystemList' looking for the particular node - * whose 'fsPtr' member matches 'fsPtr' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'filesystemList' looking for the particular node whose + * 'fsPtr' member matches 'fsPtr' and remove that one from the list. + * Ensure that the "default" node cannot be removed. */ fsRecPtr = filesystemList; @@ -940,19 +976,20 @@ Tcl_FSUnregister(fsPtr) if (fsRecPtr->nextPtr) { fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; } - /* - * Increment the filesystem epoch counter, since existing - * paths might conceivably now belong to different - * filesystems. This should also ensure that paths which - * have cached the filesystem which is about to be deleted - * do not reference that filesystem (which would of course - * lead to memory exceptions). + + /* + * Increment the filesystem epoch counter, since existing paths + * might conceivably now belong to different filesystems. This + * should also ensure that paths which have cached the filesystem + * which is about to be deleted do not reference that filesystem + * (which would of course lead to memory exceptions). */ + theFilesystemEpoch++; - + fsRecPtr->fileRefCount--; if (fsRecPtr->fileRefCount <= 0) { - ckfree((char *)fsRecPtr); + ckfree((char *)fsRecPtr); } retVal = TCL_OK; @@ -962,7 +999,7 @@ Tcl_FSUnregister(fsPtr) } Tcl_MutexUnlock(&filesystemMutex); - return (retVal); + return retVal; } /* @@ -970,49 +1007,47 @@ Tcl_FSUnregister(fsPtr) * * Tcl_FSMatchInDirectory -- * - * This routine is used by the globbing code to search a directory - * for all files which match a given pattern. The appropriate - * function for the filesystem to which pathPtr belongs will be - * called. If pathPtr does not belong to any filesystem and if it - * is NULL or the empty string, then we assume the pattern is to be - * matched in the current working directory. To avoid each - * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this - * issue, we create a pathPtr on the fly (equal to the cwd), and - * then remove it from the results returned. This makes filesystems - * easy to write, since they can assume the pathPtr passed to them - * is an ordinary path. In fact this means we could remove such - * special case handling from Tcl's native filesystems. - * - * If 'pattern' is NULL, then pathPtr is assumed to be a fully - * specified path of a single file/directory which must be - * checked for existence and correct type. - * - * Results: - * - * The return value is a standard Tcl result indicating whether an - * error occurred in globbing. Error messages are placed in - * interp, but good results are placed in the resultPtr given. - * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. The appropriate function for + * the filesystem to which pathPtr belongs will be called. If pathPtr + * does not belong to any filesystem and if it is NULL or the empty + * string, then we assume the pattern is to be matched in the current + * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for + * each filesystem from having to deal with this issue, we create a + * pathPtr on the fly (equal to the cwd), and then remove it from the + * results returned. This makes filesystems easy to write, since they + * can assume the pathPtr passed to them is an ordinary path. In fact + * this means we could remove such special case handling from Tcl's + * native filesystems. + * + * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified + * path of a single file/directory which must be checked for existence + * and correct type. + * + * Results: + * + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Error messages are placed in interp, but good + * results are placed in the resultPtr given. + * * Recursive searches, e.g. - * - * glob -dir $dir -join * pkgIndex.tcl - * - * which must recurse through each directory matching '*' are - * handled internally by Tcl, by passing specific flags in a - * modified 'types' parameter. This means the actual filesystem - * only ever sees patterns which match in a single directory. + * glob -dir $dir -join * pkgIndex.tcl + * which must recurse through each directory matching '*' are handled + * internally by Tcl, by passing specific flags in a modified 'types' + * parameter. This means the actual filesystem only ever sees patterns + * which match in a single directory. * * Side effects: * The interpreter may have an error message inserted into it. * - *---------------------------------------------------------------------- + *---------------------------------------------------------------------- */ int Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) Tcl_Interp *interp; /* Interpreter to receive error messages. */ Tcl_Obj *resultPtr; /* List object to receive results. */ - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ Tcl_GlobTypeData *types; /* Object containing list of acceptable types. * May be NULL. In particular the directory @@ -1023,24 +1058,25 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) int resLength, i, ret = -1; if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { - /* - * We don't currently allow querying of mounts by external code - * (a valuable future step), so since we're the only function - * that actually knows about mounts, this means we're being - * called recursively by ourself. Return no matches. + /* + * We don't currently allow querying of mounts by external code (a + * valuable future step), so since we're the only function that + * actually knows about mounts, this means we're being called + * recursively by ourself. Return no matches. */ + return TCL_OK; } - + if (pathPtr != NULL) { - fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); } else { fsPtr = NULL; } - + /* - * Check if we've successfully mapped the path to a filesystem - * within which to search. + * Check if we've successfully mapped the path to a filesystem within + * which to search. */ if (fsPtr != NULL) { @@ -1056,9 +1092,9 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) return ret; } - /* - * If the path isn't empty, we have no idea how to match files in - * a directory which belongs to no known filesystem + /* + * If the path isn't empty, we have no idea how to match files in a + * directory which belongs to no known filesystem */ if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { @@ -1066,15 +1102,14 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) return -1; } - /* - * We have an empty or NULL path. This is defined to mean we - * must search for files within the current 'cwd'. We - * therefore use that, but then since the proc we call will - * return results which include the cwd we must then trim it - * off the front of each path in the result. We choose to deal - * with this here (in the generic code), since if we don't, - * every single filesystem's implementation of - * Tcl_FSMatchInDirectory will have to deal with it for us. + /* + * We have an empty or NULL path. This is defined to mean we must search + * for files within the current 'cwd'. We therefore use that, but then + * since the proc we call will return results which include the cwd we + * must then trim it off the front of each path in the result. We choose + * to deal with this here (in the generic code), since if we don't, every + * single filesystem's implementation of Tcl_FSMatchInDirectory will have + * to deal with it for us. */ cwd = Tcl_FSGetCwd(NULL); @@ -1094,10 +1129,14 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types) pattern, types); if (ret == TCL_OK) { FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); - /* Note that we know resultPtr and tmpResultPtr are distinct */ + + /* + * Note that we know resultPtr and tmpResultPtr are distinct. + */ + ret = Tcl_ListObjGetElements(interp, tmpResultPtr, &resLength, &elemsPtr); - for (i = 0; ret == TCL_OK && i < resLength; i++) { + for (i=0 ; ret==TCL_OK && ifsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } break; - } + } fsRecPtr = fsRecPtr->nextPtr; } - + fsRecPtr = firstFsRecPtr; while (fsRecPtr != NULL) { - /* Skip the native system next time through */ + /* + * Skip the native system next time through. + */ + if (fsRecPtr != &nativeFilesystemRecord) { Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; if (proc != NULL) { startAt = (*proc)(interp, pathPtr, startAt); } - /* + + /* * We could add an efficiency check like this: - * - * if (retVal == length-of(pathPtr)) {break;} - * + * if (retVal == length-of(pathPtr)) {break;} * but there's not much benefit. */ } @@ -1411,16 +1453,15 @@ TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) * * TclGetOpenMode -- * - * Description: - * This routine is an obsolete, limited version of - * TclGetOpenModeEx() below. It exists only to satisfy any - * extensions imprudently using it via Tcl's internal stubs table. + * This routine is an obsolete, limited version of TclGetOpenModeEx() + * below. It exists only to satisfy any extensions imprudently using it + * via Tcl's internal stubs table. * * Results: - * Same as TclGetOpenModeEx(). + * Same as TclGetOpenModeEx(). * * Side effects: - * Same as TclGetOpenModeEx(). + * Same as TclGetOpenModeEx(). * *--------------------------------------------------------------------------- */ @@ -1429,11 +1470,11 @@ int TclGetOpenMode(interp, modeString, seekFlagPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ - CONST char *modeString; /* Mode string, e.g. "r+" or - * "RDONLY CREAT". */ - int *seekFlagPtr; /* Set this to 1 if the caller - * should seek to EOF during the - * opening of the file. */ + CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY + * CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller should + * seek to EOF during the opening of + * the file. */ { int binary = 0; return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); @@ -1444,11 +1485,10 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) * * TclGetOpenModeEx -- * - * Description: * Computes a POSIX mode mask for opening a file, from a given string, - * and also sets flags to indicate whether the caller should seek to - * EOF after opening the file, and whether the caller should - * configure the channel for binary data. + * and also sets flags to indicate whether the caller should seek to EOF + * after opening the file, and whether the caller should configure the + * channel for binary data. * * Results: * On success, returns mode to pass to "open". If an error occurs, the @@ -1456,38 +1496,39 @@ TclGetOpenMode(interp, modeString, seekFlagPtr) * object to an error message. * * Side effects: - * Sets the integer referenced by seekFlagPtr to 1 to tell the caller - * to seek to EOF after opening the file, or to 0 otherwise. Sets the - * integer referenced by binaryPtr to 1 to tell the caller to seek to + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to + * seek to EOF after opening the file, or to 0 otherwise. Sets the + * integer referenced by binaryPtr to 1 to tell the caller to seek to * configure the channel for binary data, or to 0 otherwise. * * Special note: - * This code is based on a prototype implementation contributed - * by Mark Diekhans. + * This code is based on a prototype implementation contributed by Mark + * Diekhans. * *--------------------------------------------------------------------------- */ + int TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) Tcl_Interp *interp; /* Interpreter to use for error * reporting - may be NULL. */ - CONST char *modeString; /* Mode string, e.g. "r+" or - * "RDONLY CREAT". */ - int *seekFlagPtr; /* Set this to 1 if the caller - * should seek to EOF during the - * opening of the file. */ - int *binaryPtr; /* Set this to 1 if the caller - * should configure the opened - * channel for binary operations */ + CONST char *modeString; /* Mode string, e.g. "r+" or "RDONLY + * CREAT". */ + int *seekFlagPtr; /* Set this to 1 if the caller should + * seek to EOF during the opening of + * the file. */ + int *binaryPtr; /* Set this to 1 if the caller should + * configure the opened channel for + * binary operations */ { int mode, modeArgc, c, i, gotRW; CONST char **modeArgv, *flag; #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They - * are distinguished from the POSIX access modes by the presence - * of a lower-case first letter. + * Check for the simpler fopen-like access modes (e.g. "r"). They are + * distinguished from the POSIX access modes by the presence of a + * lower-case first letter. */ *seekFlagPtr = 0; @@ -1502,26 +1543,25 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) if (!(modeString[0] & 0x80) && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ switch (modeString[0]) { - case 'r': - mode = O_RDONLY; - break; - case 'w': - mode = O_WRONLY|O_CREAT|O_TRUNC; - break; - case 'a': - mode = O_WRONLY|O_CREAT; - *seekFlagPtr = 1; - break; - default: - error: - *seekFlagPtr = 0; - *binaryPtr = 0; - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, - "illegal access mode \"", modeString, "\"", - (char *) NULL); - } - return -1; + case 'r': + mode = O_RDONLY; + break; + case 'w': + mode = O_WRONLY|O_CREAT|O_TRUNC; + break; + case 'a': + mode = O_WRONLY|O_CREAT; + *seekFlagPtr = 1; + break; + default: + error: + *seekFlagPtr = 0; + *binaryPtr = 0; + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "illegal access mode \"", modeString, + "\"", (char *) NULL); + } + return -1; } i=1; while (i<3 && modeString[i]) { @@ -1529,41 +1569,41 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) goto error; } switch (modeString[i++]) { - case '+': - mode &= ~(O_RDONLY|O_WRONLY); - mode |= O_RDWR; - break; - case 'b': - *binaryPtr = 1; - break; - default: - goto error; + case '+': + mode &= ~(O_RDONLY|O_WRONLY); + mode |= O_RDWR; + break; + case 'b': + *binaryPtr = 1; + break; + default: + goto error; } } if (modeString[i] != 0) { goto error; } - return mode; + return mode; } /* - * The access modes are specified using a list of POSIX modes - * such as O_CREAT. + * The access modes are specified using a list of POSIX modes such as + * O_CREAT. * - * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when - * a NULL interpreter is passed in. + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL + * interpreter is passed in. */ if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AddErrorInfo(interp, - "\n while processing open access modes \""); - Tcl_AddErrorInfo(interp, modeString); - Tcl_AddErrorInfo(interp, "\""); - } - return -1; + if (interp != (Tcl_Interp *) NULL) { + Tcl_AddErrorInfo(interp, + "\n while processing open access modes \""); + Tcl_AddErrorInfo(interp, modeString); + Tcl_AddErrorInfo(interp, "\""); + } + return -1; } - + gotRW = 0; for (i = 0; i < modeArgc; i++) { flag = modeArgv[i]; @@ -1579,22 +1619,24 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) gotRW = 1; } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { mode |= O_APPEND; - *seekFlagPtr = 1; + *seekFlagPtr = 1; } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { mode |= O_CREAT; } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { mode |= O_EXCL; + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { #ifdef O_NOCTTY mode |= O_NOCTTY; #else if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); return -1; #endif + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { #if defined(O_NDELAY) || defined(O_NONBLOCK) # ifdef O_NONBLOCK @@ -1602,41 +1644,49 @@ TclGetOpenModeEx(interp, modeString, seekFlagPtr, binaryPtr) # else mode |= O_NDELAY; # endif + #else - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode \"", flag, - "\" not supported by this system", (char *) NULL); - } - ckfree((char *) modeArgv); + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode \"", flag, + "\" not supported by this system", (char *) NULL); + } + ckfree((char *) modeArgv); return -1; #endif + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { mode |= O_TRUNC; } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) { *binaryPtr = 1; } else { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "invalid access mode \"", flag, + + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "invalid access mode \"", flag, "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); - } + } ckfree((char *) modeArgv); return -1; } } + ckfree((char *) modeArgv); + if (!gotRW) { - if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "access mode must include either", - " RDONLY, WRONLY, or RDWR", (char *) NULL); - } + if (interp != (Tcl_Interp *) NULL) { + Tcl_AppendResult(interp, "access mode must include either", + " RDONLY, WRONLY, or RDWR", (char *) NULL); + } return -1; } return mode; } -/* Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument */ +/* + * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. + */ + int Tcl_FSEvalFile(interp, pathPtr) Tcl_Interp *interp; /* Interpreter in which to process file. */ @@ -1651,18 +1701,17 @@ Tcl_FSEvalFile(interp, pathPtr) * * Tcl_FSEvalFileEx -- * - * Read in a file and process the entire file as one gigantic - * Tcl command. + * Read in a file and process the entire file as one gigantic Tcl + * command. * * Results: - * A standard Tcl result, which is either the result of executing - * the file or an error indicating why the file couldn't be read. + * A standard Tcl result, which is either the result of executing the + * file or an error indicating why the file couldn't be read. * * Side effects: - * Depends on the commands in the file. During the evaluation - * of the contents of the file, iPtr->scriptFile is made to - * point to pathPtr (the old value is cached and replaced when - * this function returns). + * Depends on the commands in the file. During the evaluation of the + * contents of the file, iPtr->scriptFile is made to point to pathPtr + * (the old value is cached and replaced when this function returns). * *---------------------------------------------------------------------- */ @@ -1672,8 +1721,8 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_Interp *interp; /* Interpreter in which to process file. */ Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution * will be performed on this name. */ - CONST char *encodingName; /* If non-NULL, then use this encoding - * for the file. */ + CONST char *encodingName; /* If non-NULL, then use this encoding for the + * file. */ { int result, length; Tcl_StatBuf statBuf; @@ -1691,31 +1740,33 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) objPtr = Tcl_NewObj(); if (Tcl_FSStat(pathPtr, &statBuf) == -1) { - Tcl_SetErrno(errno); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_SetErrno(errno); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); if (chan == (Tcl_Channel) NULL) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } + /* - * The eofchar is \32 (^Z). This is the usual on Windows, but we - * effect this cross-platform to allow for scripted documents. - * [Bug: 2040] + * The eofchar is \32 (^Z). This is the usual on Windows, but we effect + * this cross-platform to allow for scripted documents. [Bug: 2040] */ + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); + /* - * If the encoding is specified, set it for the channel. - * Else don't touch it (and use the system encoding) - * Report error on unknown encoding. + * If the encoding is specified, set it for the channel. Else don't touch + * it (and use the system encoding) Report error on unknown encoding. */ + if (encodingName != NULL) { if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { @@ -1723,15 +1774,17 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) goto end; } } + if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { - Tcl_Close(interp, chan); - Tcl_AppendResult(interp, "couldn't read file \"", + Tcl_Close(interp, chan); + Tcl_AppendResult(interp, "couldn't read file \"", Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), (char *) NULL); goto end; } + if (Tcl_Close(interp, chan) != TCL_OK) { - goto end; + goto end; } iPtr = (Interp *) interp; @@ -1740,11 +1793,13 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_IncrRefCount(iPtr->scriptFile); string = Tcl_GetStringFromObj(objPtr, &length); result = Tcl_EvalEx(interp, string, length, 0); - /* + + /* * Now we have to be careful; the script may have changed the - * iPtr->scriptFile value, so we must reset it without - * assuming it still points to 'pathPtr'. + * iPtr->scriptFile value, so we must reset it without assuming it still + * points to 'pathPtr'. */ + if (iPtr->scriptFile != NULL) { Tcl_DecrRefCount(iPtr->scriptFile); } @@ -1753,7 +1808,6 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } else if (result == TCL_ERROR) { - /* * Record information telling where the error occurred. */ @@ -1772,7 +1826,7 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) Tcl_DecrRefCount(msg); } - end: + end: Tcl_DecrRefCount(objPtr); return result; } @@ -1783,15 +1837,15 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName) * Tcl_GetErrno -- * * Gets the current value of the Tcl error code variable. This is - * currently the global variable "errno" but could in the future - * change to something else. + * currently the global variable "errno" but could in the future change + * to something else. * * Results: * The value of the Tcl error code variable. * * Side effects: - * None. Note that the value of the Tcl error code variable is - * UNDEFINED if a call to Tcl_SetErrno did not precede this call. + * None. Note that the value of the Tcl error code variable is UNDEFINED + * if a call to Tcl_SetErrno did not precede this call. * *---------------------------------------------------------------------- */ @@ -1830,14 +1884,13 @@ Tcl_SetErrno(err) * * Tcl_PosixError -- * - * This procedure is typically called after UNIX kernel calls - * return errors. It stores machine-readable information about - * the error in errorCode field of interp and returns an - * information string for the caller's use. + * This procedure is typically called after UNIX kernel calls return + * errors. It stores machine-readable information about the error in + * errorCode field of interp and returns an information string for the + * caller's use. * * Results: - * The return value is a human-readable string describing the - * error. + * The return value is a human-readable string describing the error. * * Side effects: * The errorCode field of the interp is set. @@ -1847,7 +1900,7 @@ Tcl_SetErrno(err) CONST char * Tcl_PosixError(interp) - Tcl_Interp *interp; /* Interpreter whose errorCode field + Tcl_Interp *interp; /* Interpreter whose errorCode field * is to be set. */ { CONST char *id, *msg; @@ -1864,15 +1917,15 @@ Tcl_PosixError(interp) * Tcl_FSStat -- * * This procedure replaces the library version of stat and lsat. - * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * See stat documentation. + * See stat documentation. * * Side effects: - * See stat documentation. + * See stat documentation. * *---------------------------------------------------------------------- */ @@ -1888,12 +1941,12 @@ Tcl_FSStat(pathPtr, buf) int retVal = -1; /* - * Call each of the "stat" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. + * Call each of the "stat" function in succession. A non-return value of + * -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); - + if (statProcList != NULL) { StatProc *statProcPtr; char *path; @@ -1913,13 +1966,14 @@ Tcl_FSStat(pathPtr, buf) Tcl_DecrRefCount(transPtr); } } - + Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { /* - * Note that EOVERFLOW is not a problem here, and these - * assignments should all be widening (if not identity.) + * Note that EOVERFLOW is not a problem here, and these assignments + * should all be widening (if not identity.) */ + buf->st_mode = oldStyleStatBuffer.st_mode; buf->st_ino = oldStyleStatBuffer.st_ino; buf->st_dev = oldStyleStatBuffer.st_dev; @@ -1935,9 +1989,10 @@ Tcl_FSStat(pathPtr, buf) buf->st_blksize = oldStyleStatBuffer.st_blksize; buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); #endif - return retVal; + return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSStatProc *proc = fsPtr->statProc; @@ -1954,17 +2009,16 @@ Tcl_FSStat(pathPtr, buf) * * Tcl_FSLstat -- * - * This procedure replaces the library version of lstat. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. If no 'lstat' function is listed, - * but a 'stat' function is, then Tcl will fall back on the - * stat function. + * This procedure replaces the library version of lstat. The appropriate + * function for the filesystem to which pathPtr belongs will be called. + * If no 'lstat' function is listed, but a 'stat' function is, then Tcl + * will fall back on the stat function. * * Results: - * See lstat documentation. + * See lstat documentation. * * Side effects: - * See lstat documentation. + * See lstat documentation. * *---------------------------------------------------------------------- */ @@ -1995,15 +2049,15 @@ Tcl_FSLstat(pathPtr, buf) * * Tcl_FSAccess -- * - * This procedure replaces the library version of access. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This procedure replaces the library version of access. The + * appropriate function for the filesystem to which pathPtr belongs will + * be called. * * Results: - * See access documentation. + * See access documentation. * * Side effects: - * See access documentation. + * See access documentation. * *---------------------------------------------------------------------- */ @@ -2011,15 +2065,15 @@ Tcl_FSLstat(pathPtr, buf) int Tcl_FSAccess(pathPtr, mode) Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ - int mode; /* Permission setting. */ + int mode; /* Permission setting. */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS int retVal = -1; /* - * Call each of the "access" function in succession. A non-return - * value of -1 indicates the particular function has succeeded. + * Call each of the "access" function in succession. A non-return value + * of -1 indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); @@ -2043,12 +2097,13 @@ Tcl_FSAccess(pathPtr, mode) Tcl_DecrRefCount(transPtr); } } - + Tcl_MutexUnlock(&obsoleteFsHookMutex); if (retVal != -1) { return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSAccessProc *proc = fsPtr->accessProc; @@ -2066,38 +2121,36 @@ Tcl_FSAccess(pathPtr, mode) * * Tcl_FSOpenFileChannel -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: * The new channel or NULL, if the named file could not be opened. * * Side effects: - * May open the channel and may cause creation of a file on the - * file system. + * May open the channel and may cause creation of a file on the file + * system. * *---------------------------------------------------------------------- */ - + Tcl_Channel Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) - Tcl_Interp *interp; /* Interpreter for error reporting; - * can be NULL. */ - Tcl_Obj *pathPtr; /* Name of file to open. */ - CONST char *modeString; /* A list of POSIX open modes or - * a string such as "rw". */ - int permissions; /* If the open involves creating a - * file, with what modes to create - * it? */ + Tcl_Interp *interp; /* Interpreter for error reporting; can be + * NULL. */ + Tcl_Obj *pathPtr; /* Name of file to open. */ + CONST char *modeString; /* A list of POSIX open modes or a string such + * as "rw". */ + int permissions; /* If the open involves creating a file, with + * what modes to create it? */ { Tcl_Filesystem *fsPtr; #ifdef USE_OBSOLETE_FS_HOOKS Tcl_Channel retVal = NULL; /* - * Call each of the "Tcl_OpenFileChannel" functions in succession. - * A non-NULL return value indicates the particular function has - * succeeded. + * Call each of the "Tcl_OpenFileChannel" functions in succession. A + * non-NULL return value indicates the particular function has succeeded. */ Tcl_MutexLock(&obsoleteFsHookMutex); @@ -2105,7 +2158,7 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) OpenFileChannelProc *openFileChannelProcPtr; char *path; Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); - + if (transPtr == NULL) { path = NULL; } else { @@ -2113,10 +2166,10 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) } openFileChannelProcPtr = openFileChannelProcList; - + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { retVal = (*openFileChannelProcPtr->proc)(interp, path, - modeString, permissions); + modeString, permissions); openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; } if (transPtr != NULL) { @@ -2128,34 +2181,37 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ - - /* - * We need this just to ensure we return the correct error messages - * under some circumstances. + + /* + * We need this just to ensure we return the correct error messages under + * some circumstances. */ + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { - return NULL; + return NULL; } - + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; if (proc != NULL) { int mode, seekFlag, binary; + mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); if (mode == -1) { - return NULL; + return NULL; } + retVal = (*proc)(interp, pathPtr, mode, permissions); if (retVal != NULL) { if (seekFlag) { - if (Tcl_Seek(retVal, (Tcl_WideInt)0, - SEEK_END) < (Tcl_WideInt)0) { + if (Tcl_Seek(retVal, (Tcl_WideInt)0, + SEEK_END) < (Tcl_WideInt)0) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "could not seek to end of file while opening \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetString(pathPtr), "\": ", + Tcl_PosixError(interp), (char *) NULL); } Tcl_Close(NULL, retVal); return NULL; @@ -2169,12 +2225,15 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) return retVal; } } - /* File doesn't belong to any filesystem that can open it */ + + /* + * File doesn't belong to any filesystem that can open it. + */ + Tcl_SetErrno(ENOENT); if (interp != NULL) { - Tcl_AppendResult(interp, "couldn't open \"", - Tcl_GetString(pathPtr), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), + "\": ", Tcl_PosixError(interp), (char *) NULL); } return NULL; } @@ -2184,24 +2243,23 @@ Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) * * Tcl_FSUtime -- * - * This procedure replaces the library version of utime. - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * This procedure replaces the library version of utime. The appropriate + * function for the filesystem to which pathPtr belongs will be called. * * Results: - * See utime documentation. + * See utime documentation. * * Side effects: - * See utime documentation. + * See utime documentation. * *---------------------------------------------------------------------- */ -int -Tcl_FSUtime (pathPtr, tval) - Tcl_Obj *pathPtr; /* File to change access/modification times */ - struct utimbuf *tval; /* Structure containing access/modification - * times to use. Should not be modified. */ +int +Tcl_FSUtime(pathPtr, tval) + Tcl_Obj *pathPtr; /* File to change access/modification times */ + struct utimbuf *tval; /* Structure containing access/modification + * times to use. Should not be modified. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2218,17 +2276,17 @@ Tcl_FSUtime (pathPtr, tval) * * NativeFileAttrStrings -- * - * This procedure implements the platform dependent 'file - * attributes' subcommand, for the native filesystem, for listing - * the set of possible attribute strings. This function is part - * of Tcl's native filesystem support, and is placed here because - * it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for listing the set of possible + * attribute strings. This function is part of Tcl's native filesystem + * support, and is placed here because it is shared by Unix and Windows + * code. * * Results: - * An array of strings + * An array of strings * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2246,21 +2304,19 @@ NativeFileAttrStrings(pathPtr, objPtrRef) * * NativeFileAttrsGet -- * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'get' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'get' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. The object placed in objPtrRef - * (if TCL_OK was returned) is likely to have a refCount of zero. - * Either way we must either store it somewhere (e.g. the Tcl - * result), or Incr/Decr its refCount to ensure it is properly - * freed. + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we + * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2272,8 +2328,8 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj **objPtrRef; /* for output. */ { - return (*tclpFileAttrProcs[index].getProc)(interp, index, - pathPtr, objPtrRef); + return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr, + objPtrRef); } /* @@ -2281,17 +2337,16 @@ NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) * * NativeFileAttrsSet -- * - * This procedure implements the platform dependent - * 'file attributes' subcommand, for the native - * filesystem, for 'set' operations. This function is part - * of Tcl's native filesystem support, and is placed here - * because it is shared by Unix and Windows code. + * This procedure implements the platform dependent 'file attributes' + * subcommand, for the native filesystem, for 'set' operations. This + * function is part of Tcl's native filesystem support, and is placed + * here because it is shared by Unix and Windows code. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2303,8 +2358,7 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) Tcl_Obj *pathPtr; /* path of file we are operating on. */ Tcl_Obj *objPtr; /* set to this value. */ { - return (*tclpFileAttrProcs[index].setProc)(interp, index, - pathPtr, objPtr); + return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr); } /* @@ -2312,30 +2366,29 @@ NativeFileAttrsSet(interp, index, pathPtr, objPtr) * * Tcl_FSFileAttrStrings -- * - * This procedure implements part of the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * This procedure implements part of the hookable 'file attributes' + * subcommand. The appropriate function for the filesystem to which + * pathPtr belongs will be called. * * Results: - * The called procedure may either return an array of strings, - * or may instead return NULL and place a Tcl list into the - * given objPtrRef. Tcl will take that list and first increment - * its refCount before using it. On completion of that use, Tcl - * will decrement its refCount. Hence if the list should be - * disposed of by Tcl when done, it should have a refCount of zero, - * and if the list should not be disposed of, the filesystem - * should ensure it retains a refCount on the object. + * The called procedure may either return an array of strings, or may + * instead return NULL and place a Tcl list into the given objPtrRef. + * Tcl will take that list and first increment its refCount before using + * it. On completion of that use, Tcl will decrement its refCount. Hence + * if the list should be disposed of by Tcl when done, it should have a + * refCount of zero, and if the list should not be disposed of, the + * filesystem should ensure it retains a refCount on the object. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ CONST char ** Tcl_FSFileAttrStrings(pathPtr, objPtrRef) - Tcl_Obj* pathPtr; - Tcl_Obj** objPtrRef; + Tcl_Obj *pathPtr; + Tcl_Obj **objPtrRef; { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -2353,8 +2406,8 @@ Tcl_FSFileAttrStrings(pathPtr, objPtrRef) * * TclFSFileAttrIndex -- * - * Helper function for converting an attribute name to an index - * into the attribute table. + * Helper function for converting an attribute name to an index into the + * attribute table. * * Results: * Tcl result code, index written to *indexPtr on result==TCL_OK @@ -2404,7 +2457,7 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) * It's a non-constant attribute list, so do a literal search. */ - int i, objc; + int i, objc; Tcl_Obj **objv; if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { @@ -2431,19 +2484,17 @@ TclFSFileAttrIndex(pathPtr, attributeName, indexPtr) * Tcl_FSFileAttrsGet -- * * This procedure implements read access for the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * attributes' subcommand. The appropriate function for the filesystem + * to which pathPtr belongs will be called. * * Results: - * Standard Tcl return code. The object placed in objPtrRef - * (if TCL_OK was returned) is likely to have a refCount of zero. - * Either way we must either store it somewhere (e.g. the Tcl - * result), or Incr/Decr its refCount to ensure it is properly - * freed. - + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we + * must either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2472,14 +2523,14 @@ Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) * Tcl_FSFileAttrsSet -- * * This procedure implements write access for the hookable 'file - * attributes' subcommand. The appropriate function for the - * filesystem to which pathPtr belongs will be called. + * attributes' subcommand. The appropriate function for the filesystem + * to which pathPtr belongs will be called. * * Results: - * Standard Tcl return code. + * Standard Tcl return code. * * Side effects: - * None. + * None. * *---------------------------------------------------------------------- */ @@ -2508,34 +2559,32 @@ Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) * Tcl_FSGetCwd -- * * This function replaces the library version of getcwd(). - * - * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains - * its own record (in a Tcl_Obj) of the cwd, and an attempt - * is made to synchronise this with the cwd's containing filesystem, - * if that filesystem provides a cwdProc (e.g. the native filesystem). - * - * Note that if Tcl's cwd is not in the native filesystem, then of - * course Tcl's cwd and the native cwd are different: extensions - * should therefore ensure they only access the cwd through this - * function to avoid confusion. - * + * + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its + * own record (in a Tcl_Obj) of the cwd, and an attempt is made to + * synchronise this with the cwd's containing filesystem, if that + * filesystem provides a cwdProc (e.g. the native filesystem). + * + * Note that if Tcl's cwd is not in the native filesystem, then of course + * Tcl's cwd and the native cwd are different: extensions should + * therefore ensure they only access the cwd through this function to + * avoid confusion. + * * If a global cwdPathPtr already exists, it is cached in the thread's * private data structures and reference to the cached copy is returned, * subject to a synchronisation attempt in that cwdPathPtr's fs. - * - * Otherwise, the chain of functions that have been "inserted" - * into the filesystem will be called in succession until either a - * value other than NULL is returned, or the entire list is - * visited. + * + * Otherwise, the chain of functions that have been "inserted" into the + * filesystem will be called in succession until either a value other + * than NULL is returned, or the entire list is visited. * * Results: - * The result is a pointer to a Tcl_Obj specifying the current - * directory, or NULL if the current directory could not be - * determined. If NULL is returned, an error message is left in the - * interp's result. - * - * The result already has its refCount incremented for the caller. - * When it is no longer needed, that refCount should be decremented. + * The result is a pointer to a Tcl_Obj specifying the current directory, + * or NULL if the current directory could not be determined. If NULL is + * returned, an error message is left in the interp's result. + * + * The result already has its refCount incremented for the caller. When + * it is no longer needed, that refCount should be decremented. * * Side effects: * Various objects may be freed and allocated. @@ -2548,16 +2597,15 @@ Tcl_FSGetCwd(interp) Tcl_Interp *interp; { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); - + if (TclFSCwdPointerEquals(NULL)) { FilesystemRecord *fsRecPtr; Tcl_Obj *retVal = NULL; - /* - * We've never been called before, try to find a cwd. Call - * each of the "Tcl_GetCwd" function in succession. A non-NULL - * return value indicates the particular function has - * succeeded. + /* + * We've never been called before, try to find a cwd. Call each of + * the "Tcl_GetCwd" function in succession. A non-NULL return value + * indicates the particular function has succeeded. */ fsRecPtr = FsGetFirstFilesystem(); @@ -2567,27 +2615,30 @@ Tcl_FSGetCwd(interp) if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { ClientData retCd; TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - + retCd = (*proc2)(NULL); if (retCd != NULL) { Tcl_Obj *norm; /* Looks like a new current directory */ - retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(retCd); + retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( + retCd); Tcl_IncrRefCount(retVal); - norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); + norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); if (norm != NULL) { - /* - * We found a cwd, which is now in our global storage. - * We must make a copy. Norm already has a refCount of 1. - * - * Threading issue: note that multiple threads at system - * startup could in principle call this procedure - * simultaneously. They will therefore each set the - * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, - * we'll always be in the 'else' branch below which - * is simpler. + /* + * We found a cwd, which is now in our global + * storage. We must make a copy. Norm already has + * a refCount of 1. + * + * Threading issue: note that multiple threads at + * system startup could in principle call this + * procedure simultaneously. They will therefore + * each set the cwdPathPtr independently. That + * behaviour is a bit peculiar, but should be + * fine. Once we have a cwd, we'll always be in + * the 'else' branch below which is simpler. */ + FsUpdateCwd(norm, retCd); Tcl_DecrRefCount(norm); } else { @@ -2609,29 +2660,31 @@ Tcl_FSGetCwd(interp) } fsRecPtr = fsRecPtr->nextPtr; } - /* - * Now the 'cwd' may NOT be normalized, at least on some - * platforms. For the sake of efficiency, we want a completely - * normalized cwd at all times. - * - * Finally, if retVal is NULL, we do not have a cwd, which - * could be problematic. + + /* + * Now the 'cwd' may NOT be normalized, at least on some platforms. + * For the sake of efficiency, we want a completely normalized cwd at + * all times. + * + * Finally, if retVal is NULL, we do not have a cwd, which could be + * problematic. */ + if (retVal != NULL) { Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); if (norm != NULL) { - /* - * We found a cwd, which is now in our global storage. - * We must make a copy. Norm already has a refCount of 1. - * + /* + * We found a cwd, which is now in our global storage. We + * must make a copy. Norm already has a refCount of 1. + * * Threading issue: note that multiple threads at system - * startup could in principle call this procedure + * startup could in principle call this procedure * simultaneously. They will therefore each set the * cwdPathPtr independently. That behaviour is a bit - * peculiar, but should be fine. Once we have a cwd, - * we'll always be in the 'else' branch below which - * is simpler. + * peculiar, but should be fine. Once we have a cwd, we'll + * always be in the 'else' branch below which is simpler. */ + ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); Tcl_DecrRefCount(norm); @@ -2639,23 +2692,24 @@ Tcl_FSGetCwd(interp) Tcl_DecrRefCount(retVal); } } else { - /* - * We already have a cwd cached, but we want to give the - * filesystem it is in a chance to check whether that cwd - * has changed, or is perhaps no longer accessible. This - * allows an error to be thrown if, say, the permissions on - * that directory have changed. + /* + * We already have a cwd cached, but we want to give the filesystem it + * is in a chance to check whether that cwd has changed, or is perhaps + * no longer accessible. This allows an error to be thrown if, say, + * the permissions on that directory have changed. */ + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); - /* - * If the filesystem couldn't be found, or if no cwd function - * exists for this filesystem, then we simply assume the cached - * cwd is ok. If we do call a cwd, we must watch for errors - * (if the cwd returns NULL). This ensures that, say, on Unix - * if the permissions of the cwd change, 'pwd' does actually - * throw the correct error in Tcl. (This is tested for in the - * test suite on unix). + + /* + * If the filesystem couldn't be found, or if no cwd function exists + * for this filesystem, then we simply assume the cached cwd is ok. + * If we do call a cwd, we must watch for errors (if the cwd returns + * NULL). This ensures that, say, on Unix if the permissions of the + * cwd change, 'pwd' does actually throw the correct error in Tcl. + * (This is tested for in the test suite on unix). */ + if (fsPtr != NULL) { Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; ClientData retCd = NULL; @@ -2663,32 +2717,37 @@ Tcl_FSGetCwd(interp) Tcl_Obj *retVal; if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; - + retCd = (*proc2)(tsdPtr->cwdClientData); if (retCd == NULL && interp != NULL) { Tcl_AppendResult(interp, "error getting working directory name: ", Tcl_PosixError(interp), (char *) NULL); } - + if (retCd == tsdPtr->cwdClientData) { goto cdDidNotChange; } - - /* Looks like a new current directory */ + + /* + * Looks like a new current directory. + */ + retVal = (*fsPtr->internalToNormalizedProc)(retCd); Tcl_IncrRefCount(retVal); } else { retVal = (*proc)(interp); } if (retVal != NULL) { - Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, - NULL); - /* - * Check whether cwd has changed from the value - * previously stored in cwdPathPtr. Really 'norm' - * shouldn't be null, but we are careful. + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, + retVal, NULL); + + /* + * Check whether cwd has changed from the value previously + * stored in cwdPathPtr. Really 'norm' shouldn't be null, + * but we are careful. */ + if (norm == NULL) { /* Do nothing */ if (retCd != NULL) { @@ -2697,27 +2756,29 @@ Tcl_FSGetCwd(interp) } else if (norm == tsdPtr->cwdPathPtr) { goto cdEqual; } else { - /* - * Note that both 'norm' and - * 'tsdPtr->cwdPathPtr' are normalized paths. - * Therefore we can be more efficient than - * calling 'Tcl_FSEqualPaths', and in addition - * avoid a nasty infinite loop bug when trying - * to normalize tsdPtr->cwdPathPtr. + /* + * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are + * normalized paths. Therefore we can be more + * efficient than calling 'Tcl_FSEqualPaths', and in + * addition avoid a nasty infinite loop bug when + * trying to normalize tsdPtr->cwdPathPtr. */ + int len1, len2; char *str1, *str2; + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { - /* + /* * If the paths were equal, we can be more - * efficient and retain the old path object - * which will probably already be shared. In - * this case we can simply free the normalized - * path we just calculated. + * efficient and retain the old path object which + * will probably already be shared. In this case + * we can simply free the normalized path we just + * calculated. */ - cdEqual: + + cdEqual: Tcl_DecrRefCount(norm); if (retCd != NULL) { (*fsPtr->freeInternalRepProc)(retCd); @@ -2735,13 +2796,13 @@ Tcl_FSGetCwd(interp) } } } - + cdDidNotChange: if (tsdPtr->cwdPathPtr != NULL) { Tcl_IncrRefCount(tsdPtr->cwdPathPtr); } - - return tsdPtr->cwdPathPtr; + + return tsdPtr->cwdPathPtr; } /* @@ -2750,132 +2811,136 @@ Tcl_FSGetCwd(interp) * Tcl_FSChdir -- * * This function replaces the library version of chdir(). - * - * The path is normalized and then passed to the filesystem - * which claims it. + * + * The path is normalized and then passed to the filesystem which claims + * it. * * Results: - * See chdir() documentation. If successful, we keep a - * record of the successful path in cwdPathPtr for subsequent - * calls to getcwd. + * See chdir() documentation. If successful, we keep a record of the + * successful path in cwdPathPtr for subsequent calls to getcwd. * * Side effects: - * See chdir() documentation. The global cwdPathPtr may - * change value. + * See chdir() documentation. The global cwdPathPtr may change value. * *---------------------------------------------------------------------- */ + int Tcl_FSChdir(pathPtr) Tcl_Obj *pathPtr; { Tcl_Filesystem *fsPtr; int retVal = -1; - + if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { Tcl_SetErrno(ENOENT); - return (retVal); + return retVal; } - + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSChdirProc *proc = fsPtr->chdirProc; if (proc != NULL) { - /* - * If this fails, an appropriate errno will have - * been stored using 'Tcl_SetErrno()'. + /* + * If this fails, an appropriate errno will have been stored using + * 'Tcl_SetErrno()'. */ + retVal = (*proc)(pathPtr); } else { - /* Fallback on stat-based implementation */ + /* + * Fallback on stat-based implementation. + */ + Tcl_StatBuf buf; - /* - * If the file can be stat'ed and is a directory and is - * readable, then we can chdir. If any of these actions - * fail, then 'Tcl_SetErrno()' should automatically have - * been called to set an appropriate error code + + /* + * If the file can be stat'ed and is a directory and is readable, + * then we can chdir. If any of these actions fail, then + * 'Tcl_SetErrno()' should automatically have been called to set + * an appropriate error code */ - if ((Tcl_FSStat(pathPtr, &buf) == 0) - && (S_ISDIR(buf.st_mode)) - && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { - /* We allow the chdir */ + + if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { + /* + * We allow the chdir. + */ + retVal = 0; } } } else { Tcl_SetErrno(ENOENT); } - - /* - * The cwd changed, or an error was thrown. If an error was - * thrown, we can just continue (and that will report the error - * to the user). If there was no error we must assume that the - * cwd was actually changed to the normalized value we - * calculated above, and we must therefore cache that - * information. + + /* + * The cwd changed, or an error was thrown. If an error was thrown, we + * can just continue (and that will report the error to the user). If + * there was no error we must assume that the cwd was actually changed to + * the normalized value we calculated above, and we must therefore cache + * that information. */ /* - * If the filesystem in question has a getCwdProc, then the - * correct logic which performs the part below is already part - * of the Tcl_FSGetCwd() call, so no need to replicate it again. - * This will have a side effect though. The private - * authoritative representation of the current working directory - * stored in cwdPathPtr in static memory will be out-of-sync - * with the real OS-maintained value. The first call to - * Tcl_FSGetCwd will however recalculate the private copy to - * match the OS-value so everything will work right. - * - * However, if there is no getCwdProc, then we _must_ update - * our private storage of the cwd, since this is the only - * opportunity to do that! - * - * Note: We currently call this block of code irrespective of - * whether there was a getCwdProc or not, but the code should - * all in principle work if we only call this block if - * fsPtr->getCwdProc == NULL. + * If the filesystem in question has a getCwdProc, then the correct logic + * which performs the part below is already part of the Tcl_FSGetCwd() + * call, so no need to replicate it again. This will have a side effect + * though. The private authoritative representation of the current + * working directory stored in cwdPathPtr in static memory will be + * out-of-sync with the real OS-maintained value. The first call to + * Tcl_FSGetCwd will however recalculate the private copy to match the + * OS-value so everything will work right. + * + * However, if there is no getCwdProc, then we _must_ update our private + * storage of the cwd, since this is the only opportunity to do that! + * + * Note: We currently call this block of code irrespective of whether + * there was a getCwdProc or not, but the code should all in principle + * work if we only call this block if fsPtr->getCwdProc == NULL. */ if (retVal == 0) { - /* - * Note that this normalized path may be different to what - * we found above (or at least a different object), if the - * filesystem epoch changed recently. This can actually - * happen with scripted documents very easily. Therefore - * we ask for the normalized path again (the correct value - * will have been cached as a result of the + /* + * Note that this normalized path may be different to what we found + * above (or at least a different object), if the filesystem epoch + * changed recently. This can actually happen with scripted documents + * very easily. Therefore we ask for the normalized path again (the + * correct value will have been cached as a result of the * Tcl_FSGetFileSystemForPath call above anyway). */ + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (normDirName == NULL) { /* Not really true, but what else to do? */ - Tcl_SetErrno(ENOENT); + Tcl_SetErrno(ENOENT); return -1; } + if (fsPtr == &tclNativeFilesystem) { - /* - * For the native filesystem, we keep a cache of the - * native representation of the cwd. But, we want to do - * that for the exact format that is returned by - * 'getcwd' (so that we can later compare the two - * representations for equality), which might not be - * exactly the same char-string as the native - * representation of the fully normalized path (e.g. on - * Windows there's a forward-slash vs backslash - * difference). Hence we ask for this again here. On - * Unix it might actually be true that we always have - * the correct form in the native rep in which case we - * could simply use: - * - * cd = Tcl_FSGetNativePath(pathPtr); - * - * instead. This should be examined by someone on - * Unix. + /* + * For the native filesystem, we keep a cache of the native + * representation of the cwd. But, we want to do that for the + * exact format that is returned by 'getcwd' (so that we can later + * compare the two representations for equality), which might not + * be exactly the same char-string as the native representation of + * the fully normalized path (e.g. on Windows there's a + * forward-slash vs backslash difference). Hence we ask for this + * again here. On Unix it might actually be true that we always + * have the correct form in the native rep in which case we could + * simply use: + * cd = Tcl_FSGetNativePath(pathPtr); + * instead. This should be examined by someone on Unix. */ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); ClientData cd; - /* Assumption we are using a filesystem version 2 */ + /* + * Assumption we are using a filesystem version 2. + */ + TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; cd = (*proc2)(tsdPtr->cwdClientData); FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd)); @@ -2883,8 +2948,8 @@ Tcl_FSChdir(pathPtr) FsUpdateCwd(normDirName, NULL); } } - - return (retVal); + + return retVal; } /* @@ -2892,75 +2957,74 @@ Tcl_FSChdir(pathPtr) * * Tcl_FSLoadFile -- * - * Dynamically loads a binary code file into memory and returns - * the addresses of two procedures within that file, if they are - * defined. The appropriate function for the filesystem to which - * pathPtr belongs will be called. - * - * Note that the native filesystem doesn't actually assume 'pathPtr' - * is a path. Rather it assumes pathPtr is either a path or just - * the name (tail) of a file which can be found somewhere in the - * environment's loadable path. This behaviour is not very - * compatible with virtual filesystems (and has other problems - * documented in the load man-page), so it is advised that full - * paths are always used. + * Dynamically loads a binary code file into memory and returns the + * addresses of two procedures within that file, if they are defined. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be - * unloaded by passing the clientData to the unloadProc. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - handlePtr, unloadProcPtr) +Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + handlePtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code. */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { CONST char *symbols[2]; Tcl_PackageInitProc **procPtrs[2]; ClientData clientData; int res; - + /* Initialize the arrays */ symbols[0] = sym1; symbols[1] = sym2; procPtrs[0] = proc1Ptr; procPtrs[1] = proc2Ptr; - + /* Perform the load */ - res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, - handlePtr, &clientData, unloadProcPtr); - - /* - * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a - * shared library, we don't keep the loadHandle (for TclpFindSymbol) - * and the clientData (for the unloadProc) separately. In fact we - * effectively throw away the loadHandle and only use the clientData. - * It just so happens, for the native filesystem only, that these two - * are identical. - * + res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, + handlePtr, &clientData, unloadProcPtr); + + /* + * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared + * library, we don't keep the loadHandle (for TclpFindSymbol) and the + * clientData (for the unloadProc) separately. In fact we effectively + * throw away the loadHandle and only use the clientData. It just so + * happens, for the native filesystem only, that these two are identical. + * * This also means that the signatures Tcl_FSUnloadFileProc and * Tcl_FSLoadFileProc are both misleading. */ + *handlePtr = (Tcl_LoadHandle) clientData; return res; } @@ -2971,65 +3035,64 @@ Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * TclLoadFile -- * * Dynamically loads a binary code file into memory and returns the - * addresses of a number of given procedures within that file, if - * they are defined. The appropriate function for the filesystem to - * which pathPtr belongs will be called. - * - * Note that the native filesystem doesn't actually assume 'pathPtr' - * is a path. Rather it assumes pathPtr is either a path or just - * the name (tail) of a file which can be found somewhere in the - * environment's loadable path. This behaviour is not very - * compatible with virtual filesystems (and has other problems - * documented in the load man-page), so it is advised that full - * paths are always used. - * - * This function is currently private to Tcl. It may be exported in - * the future and its interface fixed (but we should clean up the - * loadHandle/clientData confusion at that time -- see the above - * comments in Tcl_FSLoadFile for details). For a public function, - * see Tcl_FSLoadFile. + * addresses of a number of given procedures within that file, if they + * are defined. The appropriate function for the filesystem to which + * pathPtr belongs will be called. + * + * Note that the native filesystem doesn't actually assume 'pathPtr' is a + * path. Rather it assumes pathPtr is either a path or just the name + * (tail) of a file which can be found somewhere in the environment's + * loadable path. This behaviour is not very compatible with virtual + * filesystems (and has other problems documented in the load man-page), + * so it is advised that full paths are always used. + * + * This function is currently private to Tcl. It may be exported in the + * future and its interface fixed (but we should clean up the + * loadHandle/clientData confusion at that time -- see the above comments + * in Tcl_FSLoadFile for details). For a public function, see + * Tcl_FSLoadFile. * * Results: - * A standard Tcl completion code. If an error occurs, an error - * message is left in the interp's result. + * A standard Tcl completion code. If an error occurs, an error message + * is left in the interp's result. * * Side effects: - * New code suddenly appears in memory. This may later be - * unloaded by passing the clientData to the unloadProc. + * New code suddenly appears in memory. This may later be unloaded by + * passing the clientData to the unloadProc. * *---------------------------------------------------------------------- */ int -TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, +TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, handlePtr, clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code. */ - int symc; /* Number of symbols/procPtrs in the - * next two arrays. */ - CONST char *symbols[]; /* Names of procedures to look up in - * the file's symbol table. */ + int symc; /* Number of symbols/procPtrs in the next two + * arrays. */ + CONST char *symbols[]; /* Names of procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **procPtrs[]; - /* Where to return the addresses - * corresponding to symbols[]. */ - Tcl_LoadHandle *handlePtr; /* Filled with token for shared - * library information which can be - * used in TclpFindSymbol. */ + /* Where to return the addresses corresponding + * to symbols[]. */ + Tcl_LoadHandle *handlePtr; /* Filled with token for shared library + * information which can be used in + * TclpFindSymbol. */ ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; - /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + Tcl_FSUnloadFileProc **unloadProcPtr; + /* Filled with address of Tcl_FSUnloadFileProc + * function which should be used for this + * file. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; Tcl_Filesystem *copyFsPtr; Tcl_Obj *copyToPtr; - + if (proc != NULL) { int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); if (retVal == TCL_OK) { @@ -3037,113 +3100,126 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, if (*handlePtr == NULL) { return TCL_ERROR; } - for (i = 0;i < symc;i++) { + for (i=0 ; iloadHandle = newLoadHandle; tvdlPtr->unloadProcPtr = newUnloadProcPtr; @@ -3228,24 +3304,25 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, /* copyToPtr is already incremented for this reference */ tvdlPtr->divertedFile = copyToPtr; - /* - * This is the filesystem we loaded it into. Since - * we have a reference to 'copyToPtr', we already - * have a refCount on this filesystem, so we don't - * need to worry about it disappearing on us. + /* + * This is the filesystem we loaded it into. Since we have a + * reference to 'copyToPtr', we already have a refCount on + * this filesystem, so we don't need to worry about it + * disappearing on us. */ + tvdlPtr->divertedFilesystem = copyFsPtr; tvdlPtr->divertedFileNativeRep = NULL; } else { /* We need the native rep */ - tvdlPtr->divertedFileNativeRep = - TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, - copyFsPtr)); - /* - * We don't need or want references to the copied - * Tcl_Obj or the filesystem if it is the native - * one. + tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( + Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); + + /* + * We don't need or want references to the copied Tcl_Obj or + * the filesystem if it is the native one. */ + tvdlPtr->divertedFile = NULL; tvdlPtr->divertedFilesystem = NULL; Tcl_DecrRefCount(copyToPtr); @@ -3253,12 +3330,16 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, copyToPtr = NULL; (*handlePtr) = newLoadHandle; - (*clientDataPtr) = (ClientData)tvdlPtr; + (*clientDataPtr) = (ClientData) tvdlPtr; (*unloadProcPtr) = &FSUnloadTempFile; Tcl_ResetResult(interp); return retVal; + } else { - /* Cross-platform copy failed */ + /* + * Cross-platform copy failed. + */ + Tcl_FSDeleteFile(copyToPtr); Tcl_DecrRefCount(copyToPtr); return TCL_ERROR; @@ -3267,44 +3348,45 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs, Tcl_SetErrno(ENOENT); return TCL_ERROR; } -/* - * This function used to be in the platform specific directories, but it - * has now been made to work cross-platform +/* + * This function used to be in the platform specific directories, but it has + * now been made to work cross-platform */ + int -TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, - clientDataPtr, unloadProcPtr) +TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, + clientDataPtr, unloadProcPtr) Tcl_Interp *interp; /* Used for error reporting. */ Tcl_Obj *pathPtr; /* Name of the file containing the desired * code (UTF-8). */ - CONST char *sym1, *sym2; /* Names of two procedures to look up in - * the file's symbol table. */ + CONST char *sym1, *sym2; /* Names of two procedures to look up in the + * file's symbol table. */ Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; /* Where to return the addresses corresponding * to sym1 and sym2. */ ClientData *clientDataPtr; /* Filled with token for dynamically loaded - * file which will be passed back to + * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ - Tcl_FSUnloadFileProc **unloadProcPtr; + Tcl_FSUnloadFileProc **unloadProcPtr; /* Filled with address of Tcl_FSUnloadFileProc - * function which should be used for - * this file. */ + * function which should be used for this + * file. */ { Tcl_LoadHandle handle = NULL; int res; - + res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); - + if (res != TCL_OK) { - return res; + return res; } if (handle == NULL) { return TCL_ERROR; } - + *clientDataPtr = (ClientData)handle; - + *proc1Ptr = TclpFindSymbol(interp, handle, sym1); *proc2Ptr = TclpFindSymbol(interp, handle, sym2); return TCL_OK; @@ -3315,83 +3397,86 @@ TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, * * FSUnloadTempFile -- * - * This function is called when we loaded a library of code via - * an intermediate temporary file. This function ensures - * the library is correctly unloaded and the temporary file - * is correctly deleted. + * This function is called when we loaded a library of code via an + * intermediate temporary file. This function ensures the library is + * correctly unloaded and the temporary file is correctly deleted. * * Results: * None. * * Side effects: - * The effects of the 'unload' function called, and of course - * the temporary file will be deleted. + * The effects of the 'unload' function called, and of course the + * temporary file will be deleted. * *--------------------------------------------------------------------------- */ -static void +static void FSUnloadTempFile(loadHandle) - Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call - * to Tcl_FSLoadFile(). The loadHandle is - * a token that represents the loaded - * file. */ + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call to + * Tcl_FSLoadFile(). The loadHandle is a token + * that represents the loaded file. */ { FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; - /* - * This test should never trigger, since we give - * the client data in the function above. + + /* + * This test should never trigger, since we give the client data in the + * function above. */ + if (tvdlPtr == NULL) { return; } - - /* - * Call the real 'unloadfile' proc we actually used. It is very - * important that we call this first, so that the shared library - * is actually unloaded by the OS. Otherwise, the following - * 'delete' may well fail because the shared library is still in - * use. + + /* + * Call the real 'unloadfile' proc we actually used. It is very important + * that we call this first, so that the shared library is actually + * unloaded by the OS. Otherwise, the following 'delete' may well fail + * because the shared library is still in use. */ + if (tvdlPtr->unloadProcPtr != NULL) { (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); } - + if (tvdlPtr->divertedFilesystem == NULL) { - /* - * It was the native filesystem, and we have a special - * function available just for this purpose, which we - * know works even at this late stage. + /* + * It was the native filesystem, and we have a special function + * available just for this purpose, which we know works even at this + * late stage. */ + TclpDeleteFile(tvdlPtr->divertedFileNativeRep); NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); + } else { - /* - * Remove the temporary file we created. Note, we may crash - * here because encodings have been taken down already. + /* + * Remove the temporary file we created. Note, we may crash here + * because encodings have been taken down already. */ + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) - != TCL_OK) { - /* + != TCL_OK) { + /* * The above may have failed because the filesystem, or something * it depends upon (e.g. encodings) have been taken down because * Tcl is exiting. - * - * We may need to work out how to delete this file more - * robustly (or give the filesystem the information it needs - * to delete the file more robustly). - * - * In particular, one problem might be that the filesystem - * cannot extract the information it needs from the above - * path object because Tcl's entire filesystem apparatus - * (the code in this file) has been finalized, and it - * refuses to pass the internal representation to the - * filesystem. + * + * We may need to work out how to delete this file more robustly + * (or give the filesystem the information it needs to delete the + * file more robustly). + * + * In particular, one problem might be that the filesystem cannot + * extract the information it needs from the above path object + * because Tcl's entire filesystem apparatus (the code in this + * file) has been finalized, and it refuses to pass the internal + * representation to the filesystem. */ } - - /* - * And free up the allocations. This will also of course remove - * a refCount from the Tcl_Filesystem to which this file belongs, - * which could then free up the filesystem if we are exiting. + + /* + * And free up the allocations. This will also of course remove a + * refCount from the Tcl_Filesystem to which this file belongs, which + * could then free up the filesystem if we are exiting. */ + Tcl_DecrRefCount(tvdlPtr->divertedFile); } @@ -3403,33 +3488,30 @@ FSUnloadTempFile(loadHandle) * * Tcl_FSLink -- * - * This function replaces the library version of readlink() and - * can also be used to make links. The appropriate function for - * the filesystem to which pathPtr belongs will be called. + * This function replaces the library version of readlink() and can also + * be used to make links. The appropriate function for the filesystem to + * which pathPtr belongs will be called. * * Results: - * If toPtr is NULL, then the result is a Tcl_Obj specifying the - * contents of the symbolic link given by 'pathPtr', or NULL if - * the symbolic link could not be read. The result is owned by - * the caller, which should call Tcl_DecrRefCount when the result - * is no longer needed. - * - * If toPtr is non-NULL, then the result is toPtr if the link action - * was successful, or NULL if not. In this case the result has no - * additional reference count, and need not be freed. The actual - * action to perform is given by the 'linkAction' flags, which is - * an or'd combination of: - * - * TCL_CREATE_SYMBOLIC_LINK - * TCL_CREATE_HARD_LINK - * - * Note that most filesystems will not support linking across - * to different filesystems, so this function will usually - * fail unless toPtr is in the same FS as pathPtr. - * + * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents + * of the symbolic link given by 'pathPtr', or NULL if the symbolic link + * could not be read. The result is owned by the caller, which should + * call Tcl_DecrRefCount when the result is no longer needed. + * + * If toPtr is non-NULL, then the result is toPtr if the link action was + * successful, or NULL if not. In this case the result has no additional + * reference count, and need not be freed. The actual action to perform + * is given by the 'linkAction' flags, which is an or'd combination of: + * + * TCL_CREATE_SYMBOLIC_LINK + * TCL_CREATE_HARD_LINK + * + * Note that most filesystems will not support linking across to + * different filesystems, so this function will usually fail unless toPtr + * is in the same FS as pathPtr. + * * Side effects: - * See readlink() documentation. A new filesystem link - * object may appear + * See readlink() documentation. A new filesystem link object may appear * *--------------------------------------------------------------------------- */ @@ -3438,7 +3520,7 @@ Tcl_Obj * Tcl_FSLink(pathPtr, toPtr, linkAction) Tcl_Obj *pathPtr; /* Path of file to readlink or link */ Tcl_Obj *toPtr; /* NULL or path to be linked to */ - int linkAction; /* Action to perform */ + int linkAction; /* Action to perform */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL) { @@ -3447,13 +3529,15 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) return (*proc)(pathPtr, toPtr, linkAction); } } + /* - * If S_IFLNK isn't defined it means that the machine doesn't - * support symbolic links, so the file can't possibly be a - * symbolic link. Generate an EINVAL error, which is what - * happens on machines that do support symbolic links when - * you invoke readlink on a file that isn't a symbolic link. + * If S_IFLNK isn't defined it means that the machine doesn't support + * symbolic links, so the file can't possibly be a symbolic link. + * Generate an EINVAL error, which is what happens on machines that do + * support symbolic links when you invoke readlink on a file that isn't a + * symbolic link. */ + #ifndef S_IFLNK errno = EINVAL; #else @@ -3467,17 +3551,16 @@ Tcl_FSLink(pathPtr, toPtr, linkAction) * * Tcl_FSListVolumes -- * - * Lists the currently mounted volumes. The chain of functions - * that have been "inserted" into the filesystem will be called in - * succession; each may return a list of volumes, all of which are - * added to the result until all mounted file systems are listed. - * - * Notice that we assume the lists returned by each filesystem - * (if non NULL) have been given a refCount for us already. - * However, we are NOT allowed to hang on to the list itself - * (it belongs to the filesystem we called). Therefore we - * quite naturally add its contents to the result we are - * building, and then decrement the refCount. + * Lists the currently mounted volumes. The chain of functions that have + * been "inserted" into the filesystem will be called in succession; each + * may return a list of volumes, all of which are added to the result + * until all mounted file systems are listed. + * + * Notice that we assume the lists returned by each filesystem (if non + * NULL) have been given a refCount for us already. However, we are NOT + * allowed to hang on to the list itself (it belongs to the filesystem we + * called). Therefore we quite naturally add its contents to the result + * we are building, and then decrement the refCount. * * Results: * The list of volumes, in an object which has refCount 0. @@ -3493,12 +3576,12 @@ Tcl_FSListVolumes(void) { FilesystemRecord *fsRecPtr; Tcl_Obj *resultPtr = Tcl_NewObj(); - + /* - * Call each of the "listVolumes" function in succession. - * A non-NULL return value indicates the particular function has - * succeeded. We call all the functions registered, since we want - * a list of all drives from all filesystems. + * Call each of the "listVolumes" function in succession. A non-NULL + * return value indicates the particular function has succeeded. We call + * all the functions registered, since we want a list of all drives from + * all filesystems. */ fsRecPtr = FsGetFirstFilesystem(); @@ -3513,7 +3596,7 @@ Tcl_FSListVolumes(void) } fsRecPtr = fsRecPtr->nextPtr; } - + return resultPtr; } @@ -3522,13 +3605,12 @@ Tcl_FSListVolumes(void) * * FsListMounts -- * - * List all mounts within the given directory, which match the - * given pattern. + * List all mounts within the given directory, which match the given + * pattern. * * Results: - * The list of mounts, in a list object which has refCount 0, or - * NULL if we didn't even find any filesystems to try to list - * mounts. + * The list of mounts, in a list object which has refCount 0, or NULL if + * we didn't even find any filesystems to try to list mounts. * * Side effects: * None @@ -3538,26 +3620,25 @@ Tcl_FSListVolumes(void) static Tcl_Obj* FsListMounts(pathPtr, pattern) - Tcl_Obj *pathPtr; /* Contains path to directory to search. */ + Tcl_Obj *pathPtr; /* Contains path to directory to search. */ CONST char *pattern; /* Pattern to match against. */ { FilesystemRecord *fsRecPtr; Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; Tcl_Obj *resultPtr = NULL; - + /* - * Call each of the "matchInDirectory" functions in succession, with - * the specific type information 'mountsOnly'. A non-NULL return - * value indicates the particular function has succeeded. We call - * all the functions registered, since we want a list from each - * filesystems. + * Call each of the "matchInDirectory" functions in succession, with the + * specific type information 'mountsOnly'. A non-NULL return value + * indicates the particular function has succeeded. We call all the + * functions registered, since we want a list from each filesystems. */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_FSMatchInDirectoryProc *proc = - fsRecPtr->fsPtr->matchInDirectoryProc; + Tcl_FSMatchInDirectoryProc *proc = + fsRecPtr->fsPtr->matchInDirectoryProc; if (proc != NULL) { if (resultPtr == NULL) { resultPtr = Tcl_NewObj(); @@ -3567,7 +3648,7 @@ FsListMounts(pathPtr, pattern) } fsRecPtr = fsRecPtr->nextPtr; } - + return resultPtr; } @@ -3576,14 +3657,14 @@ FsListMounts(pathPtr, pattern) * * Tcl_FSSplitPath -- * - * This function takes the given Tcl_Obj, which should be a valid - * path, and returns a Tcl List object containing each segment of - * that path as an element. + * This function takes the given Tcl_Obj, which should be a valid path, + * and returns a Tcl List object containing each segment of that path as + * an element. * * Results: - * Returns list object with refCount of zero. If the passed in - * lenPtr is non-NULL, we use it to return the number of elements - * in the returned list. + * Returns list object with refCount of zero. If the passed in lenPtr is + * non-NULL, we use it to return the number of elements in the returned + * list. * * Side effects: * None. @@ -3591,23 +3672,23 @@ FsListMounts(pathPtr, pattern) *--------------------------------------------------------------------------- */ -Tcl_Obj* +Tcl_Obj* Tcl_FSSplitPath(pathPtr, lenPtr) Tcl_Obj *pathPtr; /* Path to split. */ int *lenPtr; /* int to store number of path elements. */ { - Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Filesystem *fsPtr; char separator = '/'; int driveNameLength; char *p; - + /* - * Perform platform specific splitting. + * Perform platform specific splitting. */ - if (TclFSGetPathType(pathPtr, &fsPtr, &driveNameLength) - == TCL_PATH_ABSOLUTE) { + if (TclFSGetPathType(pathPtr, &fsPtr, + &driveNameLength) == TCL_PATH_ABSOLUTE) { if (fsPtr == &tclNativeFilesystem) { return TclpNativeSplitPath(pathPtr, lenPtr); } @@ -3615,7 +3696,10 @@ Tcl_FSSplitPath(pathPtr, lenPtr) return TclpNativeSplitPath(pathPtr, lenPtr); } - /* We assume separators are single characters */ + /* + * We assume separators are single characters. + */ + if (fsPtr->filesystemSeparatorProc != NULL) { Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); if (sep != NULL) { @@ -3624,20 +3708,23 @@ Tcl_FSSplitPath(pathPtr, lenPtr) Tcl_DecrRefCount(sep); } } - - /* - * Place the drive name as first element of the - * result list. The drive name may contain strange - * characters, like colons and multiple forward slashes - * (for example 'ftp://' is a valid vfs drive name) + + /* + * Place the drive name as first element of the result list. The drive + * name may contain strange characters, like colons and multiple forward + * slashes (for example 'ftp://' is a valid vfs drive name) */ + result = Tcl_NewObj(); p = Tcl_GetString(pathPtr); - Tcl_ListObjAppendElement(NULL, result, - Tcl_NewStringObj(p, driveNameLength)); - p+= driveNameLength; - - /* Add the remaining path elements to the list */ + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(p, driveNameLength)); + p += driveNameLength; + + /* + * Add the remaining path elements to the list. + */ + for (;;) { char *elementStart = p; int length; @@ -3659,7 +3746,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr) break; } } - + /* * Compute the number of elements in the result. */ @@ -3671,7 +3758,7 @@ Tcl_FSSplitPath(pathPtr, lenPtr) } /* Simple helper function */ -Tcl_Obj* +Tcl_Obj* TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) Tcl_Filesystem *fromFilesystem; ClientData clientData; @@ -3686,9 +3773,9 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) } fsRecPtr = fsRecPtr->nextPtr; } - - if ((fsRecPtr != NULL) - && (fromFilesystem->internalToNormalizedProc != NULL)) { + + if ((fsRecPtr != NULL) + && (fromFilesystem->internalToNormalizedProc != NULL)) { return (*fromFilesystem->internalToNormalizedProc)(clientData); } else { return NULL; @@ -3704,9 +3791,9 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or - * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will - * be set if and only if it is non-NULL and the function's - * return value is TCL_PATH_ABSOLUTE. + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and + * only if it is non-NULL and the function's return value is + * TCL_PATH_ABSOLUTE. * * Side effects: * None. @@ -3716,33 +3803,31 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) Tcl_PathType TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Path to determine type for */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is - * non-NULL, then set to the - * filesystem which claims this - * path */ - int *driveNameLengthPtr; /* If the path is absolute, and - * this is non-NULL, then set to - * the length of the driveName */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and - * this is non-NULL, then set to - * the name of the drive, - * network-volume which contains - * the path, already with a - * refCount for the caller. */ + Tcl_Obj *pathPtr; /* Path to determine type for */ + Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not + * NULL, then set to the filesystem + * which claims this path. */ + int *driveNameLengthPtr; /* If the path is absolute, and this + * is non-NULL, then set to the length + * of the driveName. */ + Tcl_Obj **driveNameRef; /* If the path is absolute, and this + * is non-NULL, then set to the name + * of the drive, network-volume which + * contains the path, already with a + * refCount for the caller. */ { int pathLen; char *path; Tcl_PathType type; - + path = Tcl_GetStringFromObj(pathPtr, &pathLen); - type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, - driveNameLengthPtr, driveNameRef); - + type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, + driveNameLengthPtr, driveNameRef); + if (type != TCL_PATH_ABSOLUTE) { - type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, - driveNameRef); + type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, + driveNameRef); if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { *filesystemPtrPtr = &tclNativeFilesystem; } @@ -3755,17 +3840,16 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) * * TclFSNonnativePathType -- * - * Helper function used by TclGetPathType. Its purpose is to - * check whether the given path starts with a string which - * corresponds to a file volume in any registered filesystem - * except the native one. For speed and historical reasons the - * native filesystem has special hard-coded checks dotted here - * and there in the filesystem code. + * Helper function used by TclGetPathType. Its purpose is to check + * whether the given path starts with a string which corresponds to a + * file volume in any registered filesystem except the native one. For + * speed and historical reasons the native filesystem has special + * hard-coded checks dotted here and there in the filesystem code. * * Results: - * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. - * The filesystem reference will be set if and only if it is - * non-NULL and the function's return value is TCL_PATH_ABSOLUTE. + * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem + * reference will be set if and only if it is non-NULL and the function's + * return value is TCL_PATH_ABSOLUTE. * * Side effects: * None. @@ -3774,71 +3858,70 @@ TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) */ Tcl_PathType -TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, - driveNameLengthPtr, driveNameRef) - CONST char *path; /* Path to determine type for */ - int pathLen; /* Length of the path */ - Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is - * non-NULL, then set to the - * filesystem which claims this - * path */ - int *driveNameLengthPtr; /* If the path is absolute, and - * this is non-NULL, then set to - * the length of the driveName */ - Tcl_Obj **driveNameRef; /* If the path is absolute, and - * this is non-NULL, then set to - * the name of the drive, - * network-volume which contains - * the path, already with a +TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, driveNameLengthPtr, + driveNameRef) + CONST char *path; /* Path to determine type for */ + int pathLen; /* Length of the path */ + Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is not + * NULL, then set to the filesystem + * which claims this path. */ + int *driveNameLengthPtr; /* If the path is absolute, and this + * is non-NULL, then set to the length + * of the driveName. */ + Tcl_Obj **driveNameRef; /* If the path is absolute, and this + * is non-NULL, then set to the name + * of the drive, network-volume which + * contains the path, already with a * refCount for the caller. */ { FilesystemRecord *fsRecPtr; Tcl_PathType type = TCL_PATH_RELATIVE; /* - * Call each of the "listVolumes" function in succession, checking - * whether the given path is an absolute path on any of the volumes - * returned (this is done by checking whether the path's prefix - * matches). + * Call each of the "listVolumes" function in succession, checking whether + * the given path is an absolute path on any of the volumes returned (this + * is done by checking whether the path's prefix matches). */ fsRecPtr = FsGetFirstFilesystem(); while (fsRecPtr != NULL) { Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; - /* + + /* * We want to skip the native filesystem in this loop because - * otherwise we won't necessarily pass all the Tcl testsuite -- - * this is because some of the tests artificially change the - * current platform (between win, unix) but the list - * of volumes we get by calling (*proc) will reflect the current - * (real) platform only and this may cause some tests to fail. - * In particular, on unix '/' will match the beginning of - * certain absolute Windows paths starting '//' and those tests - * will go wrong. - * - * Besides these test-suite issues, there is one other reason - * to skip the native filesystem --- since the tclFilename.c - * code has nice fast 'absolute path' checkers, we don't want - * to waste time repeating that effort here, and this - * function is actually called quite often, so if we can - * save the overhead of the native filesystem returning us - * a list of volumes all the time, it is better. + * otherwise we won't necessarily pass all the Tcl testsuite -- this + * is because some of the tests artificially change the current + * platform (between win, unix) but the list of volumes we get by + * calling (*proc) will reflect the current (real) platform only and + * this may cause some tests to fail. In particular, on unix '/' will + * match the beginning of certain absolute Windows paths starting '//' + * and those tests will go wrong. + * + * Besides these test-suite issues, there is one other reason to skip + * the native filesystem --- since the tclFilename.c code has nice + * fast 'absolute path' checkers, we don't want to waste time + * repeating that effort here, and this function is actually called + * quite often, so if we can save the overhead of the native + * filesystem returning us a list of volumes all the time, it is + * better. */ + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { int numVolumes; Tcl_Obj *thisFsVolumes = (*proc)(); if (thisFsVolumes != NULL) { - if (Tcl_ListObjLength(NULL, thisFsVolumes, - &numVolumes) != TCL_OK) { - /* - * This is VERY bad; the Tcl_FSListVolumesProc - * didn't return a valid list. Set numVolumes to - * -1 so that we skip the while loop below and just - * return with the current value of 'type'. - * - * It would be better if we could signal an error - * here (but Tcl_Panic seems a bit excessive). + if (Tcl_ListObjLength(NULL, thisFsVolumes, + &numVolumes) != TCL_OK) { + /* + * This is VERY bad; the Tcl_FSListVolumesProc didn't + * return a valid list. Set numVolumes to -1 so that we + * skip the while loop below and just return with the + * current value of 'type'. + * + * It would be better if we could signal an error here + * (but Tcl_Panic seems a bit excessive). */ + numVolumes = -1; } while (numVolumes > 0) { @@ -3884,12 +3967,12 @@ TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, * * Tcl_FSRenameFile -- * - * If the two paths given belong to the same filesystem, we call - * that filesystems rename function. Otherwise we simply - * return the posix error 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems rename function. Otherwise we simply return the posix + * error 'EXDEV', and -1. * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A file may be renamed. @@ -3926,16 +4009,16 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) * * Tcl_FSCopyFile -- * - * If the two paths given belong to the same filesystem, we call - * that filesystem's copy function. Otherwise we simply - * return the posix error 'EXDEV', and -1. - * - * Note that in the native filesystems, 'copyFileProc' is defined - * to copy soft links (i.e. it copies the links themselves, not - * the things they point to). + * If the two paths given belong to the same filesystem, we call that + * filesystem's copy function. Otherwise we simply return the posix + * error 'EXDEV', and -1. + * + * Note that in the native filesystems, 'copyFileProc' is defined to copy + * soft links (i.e. it copies the links themselves, not the things they + * point to). * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A file may be copied. @@ -3943,7 +4026,7 @@ Tcl_FSRenameFile(srcPathPtr, destPathPtr) *--------------------------------------------------------------------------- */ -int +int Tcl_FSCopyFile(srcPathPtr, destPathPtr) Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ @@ -3970,57 +4053,70 @@ Tcl_FSCopyFile(srcPathPtr, destPathPtr) * * TclCrossFilesystemCopy -- * - * Helper for above function, and for Tcl_FSLoadFile, to copy - * files from one filesystem to another. This function will - * overwrite the target file if it already exists. + * Helper for above function, and for Tcl_FSLoadFile, to copy files from + * one filesystem to another. This function will overwrite the target + * file if it already exists. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A file may be created. * *--------------------------------------------------------------------------- */ -int -TclCrossFilesystemCopy(interp, source, target) +int +TclCrossFilesystemCopy(interp, source, target) Tcl_Interp *interp; /* For error messages */ Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ { int result = TCL_ERROR; int prot = 0666; - + Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); if (out != NULL) { - /* It looks like we can copy it over */ - Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, - "r", prot); + /* + * It looks like we can copy it over. + */ + + Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, "r", prot); + if (in == NULL) { - /* This is very strange, we checked this above */ + /* + * This is very strange, we checked this above + */ + Tcl_Close(interp, out); + } else { Tcl_StatBuf sourceStatBuf; struct utimbuf tval; - /* - * Copy it synchronously. We might wish to add an - * asynchronous option to support vfs's which are - * slow (e.g. network sockets). + + /* + * Copy it synchronously. We might wish to add an asynchronous + * option to support vfs's which are slow (e.g. network sockets). */ + Tcl_SetChannelOption(interp, in, "-translation", "binary"); Tcl_SetChannelOption(interp, out, "-translation", "binary"); - + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { result = TCL_OK; } - /* - * If the copy failed, assume that copy channel left - * a good error message. + + /* + * If the copy failed, assume that copy channel left a good error + * message. */ + Tcl_Close(interp, in); Tcl_Close(interp, out); - - /* Set modification date of copied file */ + + /* + * Set modification date of copied file. + */ + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { tval.actime = sourceStatBuf.st_atime; tval.modtime = sourceStatBuf.st_mtime; @@ -4036,11 +4132,11 @@ TclCrossFilesystemCopy(interp, source, target) * * Tcl_FSDeleteFile -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A file may be deleted. @@ -4068,11 +4164,11 @@ Tcl_FSDeleteFile(pathPtr) * * Tcl_FSCreateDirectory -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A directory may be created. @@ -4100,12 +4196,12 @@ Tcl_FSCreateDirectory(pathPtr) * * Tcl_FSCopyDirectory -- * - * If the two paths given belong to the same filesystem, we call - * that filesystems copy-directory function. Otherwise we simply - * return the posix error 'EXDEV', and -1. + * If the two paths given belong to the same filesystem, we call that + * filesystems copy-directory function. Otherwise we simply return the + * posix error 'EXDEV', and -1. * * Results: - * Standard Tcl error code if a function was called. + * Standard Tcl error code if a function was called. * * Side effects: * A directory may be copied. @@ -4118,9 +4214,9 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied * (UTF-8). */ Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { int retVal = -1; Tcl_Filesystem *fsPtr, *fsPtr2; @@ -4144,11 +4240,11 @@ Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) * * Tcl_FSRemoveDirectory -- * - * The appropriate function for the filesystem to which pathPtr - * belongs will be called. + * The appropriate function for the filesystem to which pathPtr belongs + * will be called. * * Results: - * Standard Tcl error code. + * Standard Tcl error code. * * Side effects: * A directory may be deleted. @@ -4160,47 +4256,50 @@ int Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) Tcl_Obj *pathPtr; /* Pathname of directory to be removed * (UTF-8). */ - int recursive; /* If non-zero, removes directories that - * are nonempty. Otherwise, will only remove + int recursive; /* If non-zero, removes directories that are + * nonempty. Otherwise, will only remove * empty directories. */ - Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a - * new object containing name of file - * causing error, with refCount 1. */ + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a new + * object containing name of file causing + * error, with refCount 1. */ { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - if (fsPtr != NULL) { + if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; - if (proc != NULL) { - if (recursive) { - /* - * We check whether the cwd lies inside this directory - * and move it if it does. - */ - Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); - if (cwdPtr != NULL) { - char *cwdStr, *normPathStr; - int cwdLen, normLen; - Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); - if ((cwdLen >= normLen) && (strncmp(normPathStr, - cwdStr, (size_t) normLen) == 0)) { - /* - * the cwd is inside the directory, so we - * perform a 'cd [file dirname $path]' - */ - Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, - TCL_PATH_DIRNAME); - Tcl_FSChdir(dirPtr); - Tcl_DecrRefCount(dirPtr); - } + if (recursive) { + /* + * We check whether the cwd lies inside this directory and move it + * if it does. + */ + + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); + + if (cwdPtr != NULL) { + char *cwdStr, *normPathStr; + int cwdLen, normLen; + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); + + if (normPath != NULL) { + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, + (size_t) normLen) == 0)) { + /* + * The cwd is inside the directory, so we perform a + * 'cd [file dirname $path]'. + */ + + Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, + TCL_PATH_DIRNAME); + + Tcl_FSChdir(dirPtr); + Tcl_DecrRefCount(dirPtr); } - Tcl_DecrRefCount(cwdPtr); } + Tcl_DecrRefCount(cwdPtr); } - return (*proc)(pathPtr, recursive, errorPtr); } + return (*proc)(pathPtr, recursive, errorPtr); } Tcl_SetErrno(ENOENT); return -1; @@ -4211,13 +4310,13 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) * * Tcl_FSGetFileSystemForPath -- * - * This function determines which filesystem to use for a - * particular path object, and returns the filesystem which - * accepts this file. If no filesystem will accept this object - * as a valid file path, then NULL is returned. + * This function determines which filesystem to use for a particular path + * object, and returns the filesystem which accepts this file. If no + * filesystem will accept this object as a valid file path, then NULL is + * returned. * * Results: -.* NULL or a filesystem which will accept this path. + * NULL or a filesystem which will accept this path. * * Side effects: * The object may be converted to a path type. @@ -4231,30 +4330,28 @@ Tcl_FSGetFileSystemForPath(pathPtr) { FilesystemRecord *fsRecPtr; Tcl_Filesystem* retVal = NULL; - + if (pathPtr == NULL) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); return NULL; } - - /* - * If the object has a refCount of zero, we reject it. This - * is to avoid possible segfaults or nondeterministic memory - * leaks (i.e. the user doesn't know if they should decrement - * the ref count on return or not). + + /* + * If the object has a refCount of zero, we reject it. This is to avoid + * possible segfaults or nondeterministic memory leaks (i.e. the user + * doesn't know if they should decrement the ref count on return or not). */ - + if (pathPtr->refCount == 0) { Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); return NULL; } - - /* - * Check if the filesystem has changed in some way since - * this object's internal representation was calculated. - * Before doing that, assure we have the most up-to-date - * copy of the master filesystem. This is accomplished - * by the FsGetFirstFilesystem() call. + + /* + * Check if the filesystem has changed in some way since this object's + * internal representation was calculated. Before doing that, assure we + * have the most up-to-date copy of the master filesystem. This is + * accomplished by the FsGetFirstFilesystem() call. */ fsRecPtr = FsGetFirstFilesystem(); @@ -4265,20 +4362,22 @@ Tcl_FSGetFileSystemForPath(pathPtr) /* * Call each of the "pathInFilesystem" functions in succession. A - * non-return value of -1 indicates the particular function has - * succeeded. + * non-return value of -1 indicates the particular function has succeeded. */ while ((retVal == NULL) && (fsRecPtr != NULL)) { - Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; + Tcl_FSPathInFilesystemProc *proc = + fsRecPtr->fsPtr->pathInFilesystemProc; + if (proc != NULL) { ClientData clientData = NULL; int ret = (*proc)(pathPtr, &clientData); if (ret != -1) { - /* - * We assume the type of pathPtr hasn't been changed - * by the above call to the pathInFilesystemProc. + /* + * We assume the type of pathPtr hasn't been changed by the + * above call to the pathInFilesystemProc. */ + TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); retVal = fsRecPtr->fsPtr; } @@ -4294,25 +4393,23 @@ Tcl_FSGetFileSystemForPath(pathPtr) * * Tcl_FSGetNativePath -- * - * This function is for use by the Win/Unix native filesystems, - * so that they can easily retrieve the native (char* or TCHAR*) - * representation of a path. Other filesystems will probably - * want to implement similar functions. They basically act as a - * safety net around Tcl_FSGetInternalRep. Normally your file- - * system procedures will always be called with path objects - * already converted to the correct filesystem, but if for - * some reason they are called directly (i.e. by procedures - * not in this file), then one cannot necessarily guarantee that - * the path object pointer is from the correct filesystem. - * - * Note: in the future it might be desireable to have separate - * versions of this function with different signatures, for - * example Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. - * Right now, since native paths are all string based, we use just - * one function. + * This function is for use by the Win/Unix native filesystems, so that + * they can easily retrieve the native (char* or TCHAR*) representation + * of a path. Other filesystems will probably want to implement similar + * functions. They basically act as a safety net around + * Tcl_FSGetInternalRep. Normally your file- system procedures will + * always be called with path objects already converted to the correct + * filesystem, but if for some reason they are called directly (i.e. by + * procedures not in this file), then one cannot necessarily guarantee + * that the path object pointer is from the correct filesystem. + * + * Note: in the future it might be desireable to have separate versions + * of this function with different signatures, for example + * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since + * native paths are all string based, we use just one function. * * Results: - * NULL or a valid native path. + * NULL or a valid native path. * * Side effects: * See Tcl_FSGetInternalRep. @@ -4324,7 +4421,7 @@ CONST char * Tcl_FSGetNativePath(pathPtr) Tcl_Obj *pathPtr; { - return (CONST char *)Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); + return (CONST char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); } /* @@ -4332,21 +4429,22 @@ Tcl_FSGetNativePath(pathPtr) * * NativeFreeInternalRep -- * - * Free a native internal representation, which will be non-NULL. + * Free a native internal representation, which will be non-NULL. * * Results: - * None. + * None. * * Side effects: * Memory is released. * *--------------------------------------------------------------------------- */ -static void + +static void NativeFreeInternalRep(clientData) ClientData clientData; { - ckfree((char*)clientData); + ckfree((char *) clientData); } /* @@ -4354,19 +4452,19 @@ NativeFreeInternalRep(clientData) * * Tcl_FSFileSystemInfo -- * - * This function returns a list of two elements. The first - * element is the name of the filesystem (e.g. "native" or "vfs"), - * and the second is the particular type of the given path within - * that filesystem. + * This function returns a list of two elements. The first element is + * the name of the filesystem (e.g. "native" or "vfs"), and the second is + * the particular type of the given path within that filesystem. * * Results: - * A list of two elements. + * A list of two elements. * * Side effects: * The object may be converted to a path type. * *--------------------------------------------------------------------------- */ + Tcl_Obj* Tcl_FSFileSystemInfo(pathPtr) Tcl_Obj* pathPtr; @@ -4374,15 +4472,15 @@ Tcl_FSFileSystemInfo(pathPtr) Tcl_Obj *resPtr; Tcl_FSFilesystemPathTypeProc *proc; Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - + if (fsPtr == NULL) { return NULL; } - + resPtr = Tcl_NewListObj(0,NULL); - - Tcl_ListObjAppendElement(NULL, resPtr, - Tcl_NewStringObj(fsPtr->typeName,-1)); + + Tcl_ListObjAppendElement(NULL, resPtr, + Tcl_NewStringObj(fsPtr->typeName,-1)); proc = fsPtr->filesystemPathTypeProc; if (proc != NULL) { @@ -4391,7 +4489,7 @@ Tcl_FSFileSystemInfo(pathPtr) Tcl_ListObjAppendElement(NULL, resPtr, typePtr); } } - + return resPtr; } @@ -4400,36 +4498,37 @@ Tcl_FSFileSystemInfo(pathPtr) * * Tcl_FSPathSeparator -- * - * This function returns the separator to be used for a given - * path. The object returned should have a refCount of zero + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero * * Results: - * A Tcl object, with a refCount of zero. If the caller - * needs to retain a reference to the object, it should - * call Tcl_IncrRefCount, and should otherwise free the - * object. + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. * * Side effects: * The path object may be converted to a path type. * *--------------------------------------------------------------------------- */ + Tcl_Obj* Tcl_FSPathSeparator(pathPtr) Tcl_Obj* pathPtr; { Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); - + if (fsPtr == NULL) { return NULL; } if (fsPtr->filesystemSeparatorProc != NULL) { return (*fsPtr->filesystemSeparatorProc)(pathPtr); } else { - /* - * Allow filesystems not to provide a filesystemSeparatorProc - * if they wish to use the standard forward slash. + /* + * Allow filesystems not to provide a filesystemSeparatorProc if they + * wish to use the standard forward slash. */ + return Tcl_NewStringObj("/", 1); } } @@ -4439,29 +4538,30 @@ Tcl_FSPathSeparator(pathPtr) * * NativeFilesystemSeparator -- * - * This function is part of the native filesystem support, and - * returns the separator for the given path. + * This function is part of the native filesystem support, and returns + * the separator for the given path. * * Results: - * String object containing the separator character. + * String object containing the separator character. * * Side effects: * None. * *--------------------------------------------------------------------------- */ + static Tcl_Obj* NativeFilesystemSeparator(pathPtr) Tcl_Obj* pathPtr; { char *separator = NULL; /* lint */ switch (tclPlatform) { - case TCL_PLATFORM_UNIX: - separator = "/"; - break; - case TCL_PLATFORM_WINDOWS: - separator = "\\"; - break; + case TCL_PLATFORM_UNIX: + separator = "/"; + break; + case TCL_PLATFORM_WINDOWS: + separator = "\\"; + break; } return Tcl_NewStringObj(separator,1); } @@ -4475,18 +4575,17 @@ NativeFilesystemSeparator(pathPtr) * TclStatInsertProc -- * * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclStat(...)'. The - * passed function should behave exactly like 'TclStat' when called - * during that time (see 'TclStat(...)' for more information). - * The function will be added even if it already in the list. + * functions which are used during a call to 'TclStat(...)'. The passed + * function should behave exactly like 'TclStat' when called during that + * time (see 'TclStat(...)' for more information). The function will be + * added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for 'TclStat' - * functions. + * Memory allocated and modifies the link list for 'TclStat' functions. * *---------------------------------------------------------------------- */ @@ -4522,15 +4621,14 @@ TclStatInsertProc (proc) * TclStatDeleteProc -- * * Removed the passed function pointer from the list of 'TclStat' - * functions. Ensures that the built-in stat function is not - * removvable. + * functions. Ensures that the built-in stat function is not removvable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ @@ -4545,10 +4643,11 @@ TclStatDeleteProc (proc) Tcl_MutexLock(&obsoleteFsHookMutex); tmpStatProcPtr = statProcList; + /* - * Traverse the 'statProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'statProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. */ while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { @@ -4579,19 +4678,17 @@ TclStatDeleteProc (proc) * TclAccessInsertProc -- * * Insert the passed procedure pointer at the head of the list of - * functions which are used during a call to 'TclAccess(...)'. - * The passed function should behave exactly like 'TclAccess' when - * called during that time (see 'TclAccess(...)' for more - * information). The function will be added even if it already in - * the list. + * functions which are used during a call to 'TclAccess(...)'. The + * passed function should behave exactly like 'TclAccess' when called + * during that time (see 'TclAccess(...)' for more information). The + * function will be added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for 'TclAccess' - * functions. + * Memory allocated and modifies the link list for 'TclAccess' functions. * *---------------------------------------------------------------------- */ @@ -4631,11 +4728,11 @@ TclAccessInsertProc(proc) * removvable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ @@ -4649,9 +4746,9 @@ TclAccessDeleteProc(proc) AccessProc *prevAccessProcPtr = NULL; /* - * Traverse the 'accessProcList' looking for the particular node - * whose 'proc' member matches 'proc' and remove that one from - * the list. Ensure that the "default" node cannot be removed. + * Traverse the 'accessProcList' looking for the particular node whose + * 'proc' member matches 'proc' and remove that one from the list. Ensure + * that the "default" node cannot be removed. */ Tcl_MutexLock(&obsoleteFsHookMutex); @@ -4684,18 +4781,18 @@ TclAccessDeleteProc(proc) * * Insert the passed procedure pointer at the head of the list of * functions which are used during a call to - * 'Tcl_OpenFileChannel(...)'. The passed function should behave - * exactly like 'Tcl_OpenFileChannel' when called during that time - * (see 'Tcl_OpenFileChannel(...)' for more information). The - * function will be added even if it already in the list. + * 'Tcl_OpenFileChannel(...)'. The passed function should behave exactly + * like 'Tcl_OpenFileChannel' when called during that time (see + * 'Tcl_OpenFileChannel(...)' for more information). The function will be + * added even if it already in the list. * * Results: - * Normally TCL_OK; TCL_ERROR if memory for a new node in the list - * could not be allocated. + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could + * not be allocated. * * Side effects: - * Memory allocated and modifies the link list for - * 'Tcl_OpenFileChannel' functions. + * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel' + * functions. * *---------------------------------------------------------------------- */ @@ -4709,21 +4806,19 @@ TclOpenFileChannelInsertProc(proc) if (proc != NULL) { OpenFileChannelProc *newOpenFileChannelProcPtr; - newOpenFileChannelProcPtr = - (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); + newOpenFileChannelProcPtr = (OpenFileChannelProc *) + ckalloc(sizeof(OpenFileChannelProc)); - if (newOpenFileChannelProcPtr != NULL) { - newOpenFileChannelProcPtr->proc = proc; - Tcl_MutexLock(&obsoleteFsHookMutex); - newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; - openFileChannelProcList = newOpenFileChannelProcPtr; - Tcl_MutexUnlock(&obsoleteFsHookMutex); + newOpenFileChannelProcPtr->proc = proc; + Tcl_MutexLock(&obsoleteFsHookMutex); + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; + openFileChannelProcList = newOpenFileChannelProcPtr; + Tcl_MutexUnlock(&obsoleteFsHookMutex); - retVal = TCL_OK; - } + retVal = TCL_OK; } - return (retVal); + return retVal; } /* @@ -4732,15 +4827,15 @@ TclOpenFileChannelInsertProc(proc) * TclOpenFileChannelDeleteProc -- * * Removed the passed function pointer from the list of - * 'Tcl_OpenFileChannel' functions. Ensures that the built-in - * open file channel function is not removable. + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file + * channel function is not removable. * * Results: - * TCL_OK if the procedure pointer was successfully removed, - * TCL_ERROR otherwise. + * TCL_OK if the procedure pointer was successfully removed, TCL_ERROR + * otherwise. * * Side effects: - * Memory is deallocated and the respective list updated. + * Memory is deallocated and the respective list updated. * *---------------------------------------------------------------------- */ @@ -4754,9 +4849,8 @@ TclOpenFileChannelDeleteProc(proc) OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; /* - * Traverse the 'openFileChannelProcList' looking for the particular - * node whose 'proc' member matches 'proc' and remove that one from - * the list. + * Traverse the 'openFileChannelProcList' looking for the particular node + * whose 'proc' member matches 'proc' and remove that one from the list. */ Tcl_MutexLock(&obsoleteFsHookMutex); @@ -4771,7 +4865,7 @@ TclOpenFileChannelDeleteProc(proc) tmpOpenFileChannelProcPtr->nextPtr; } - ckfree((char *)tmpOpenFileChannelProcPtr); + ckfree((char *) tmpOpenFileChannelProcPtr); retVal = TCL_OK; } else { @@ -4784,3 +4878,11 @@ TclOpenFileChannelDeleteProc(proc) return retVal; } #endif /* USE_OBSOLETE_FS_HOOKS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index f6cc8dc..c521435 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -1,8 +1,8 @@ -/* +/* * tclInterp.c -- * - * This file implements the "interp" command which allows creation - * and manipulation of Tcl interpreters from within Tcl scripts. + * This file implements the "interp" command which allows creation and + * manipulation of Tcl interpreters from within Tcl scripts. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 2004 Donal K. Fellows @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInterp.c,v 1.59 2005/05/10 18:34:44 kennykb Exp $ + * RCS: @(#) $Id: tclInterp.c,v 1.60 2005/07/17 21:17:42 dkf Exp $ */ #include "tclInt.h" @@ -20,8 +20,8 @@ * is evaluated in Tcl_Init() prior to the built-in initialization script * above. This variable can be modified by the procedure below. */ - -static char * tclPreInitScript = NULL; + +static char * tclPreInitScript = NULL; /* Forward declaration */ @@ -30,40 +30,41 @@ struct Target; /* * struct Alias: * - * Stores information about an alias. Is stored in the slave interpreter - * and used by the source command to find the target command in the master - * when the source command is invoked. + * Stores information about an alias. Is stored in the slave interpreter and + * used by the source command to find the target command in the master when + * the source command is invoked. */ typedef struct Alias { Tcl_Obj *token; /* Token for the alias command in the slave - * interp. This used to be the command name - * in the slave when the alias was first + * interp. This used to be the command name in + * the slave when the alias was first * created. */ Tcl_Interp *targetInterp; /* Interp in which target command will be * invoked. */ - Tcl_Command slaveCmd; /* Source command in slave interpreter, - * bound to command that invokes the target - * command in the target interpreter. */ + Tcl_Command slaveCmd; /* Source command in slave interpreter, bound + * to command that invokes the target command + * in the target interpreter. */ Tcl_HashEntry *aliasEntryPtr; /* Entry for the alias hash table in slave. - * This is used by alias deletion to remove - * the alias from the slave interpreter - * alias table. */ - struct Target *targetPtr; /* Entry for target command in master. - * This is used in the master interpreter to - * map back from the target command to aliases - * redirecting to it. */ - int objc; /* Count of Tcl_Obj in the prefix of the - * target command to be invoked in the - * target interpreter. Additional arguments - * specified when calling the alias in the - * slave interp will be appended to the prefix - * before the command is invoked. */ - Tcl_Obj *objPtr; /* The first actual prefix object - the target - * command name; this has to be at the end of the - * structure, which will be extended to accomodate - * the remaining objects in the prefix. */ + * This is used by alias deletion to remove + * the alias from the slave interpreter alias + * table. */ + struct Target *targetPtr; /* Entry for target command in master. This + * is used in the master interpreter to map + * back from the target command to aliases + * redirecting to it. */ + int objc; /* Count of Tcl_Obj in the prefix of the + * target command to be invoked in the target + * interpreter. Additional arguments specified + * when calling the alias in the slave interp + * will be appended to the prefix before the + * command is invoked. */ + Tcl_Obj *objPtr; /* The first actual prefix object - the target + * command name; this has to be at the end of + * the structure, which will be extended to + * accomodate the remaining objects in the + * prefix. */ } Alias; /* @@ -71,23 +72,23 @@ typedef struct Alias { * struct Slave: * * Used by the "interp" command to record and find information about slave - * interpreters. Maps from a command name in the master to information about - * a slave interpreter, e.g. what aliases are defined in it. + * interpreters. Maps from a command name in the master to information about a + * slave interpreter, e.g. what aliases are defined in it. */ typedef struct Slave { Tcl_Interp *masterInterp; /* Master interpreter for this slave. */ Tcl_HashEntry *slaveEntryPtr; - /* Hash entry in masters slave table for - * this slave interpreter. Used to find - * this record, and used when deleting the - * slave interpreter to delete it from the - * master's table. */ + /* Hash entry in masters slave table for this + * slave interpreter. Used to find this + * record, and used when deleting the slave + * interpreter to delete it from the master's + * table. */ Tcl_Interp *slaveInterp; /* The slave interpreter. */ Tcl_Command interpCmd; /* Interpreter object command. */ - Tcl_HashTable aliasTable; /* Table which maps from names of commands - * in slave interpreter to struct Alias - * defined below. */ + Tcl_HashTable aliasTable; /* Table which maps from names of commands in + * slave interpreter to struct Alias defined + * below. */ } Slave; /* @@ -116,22 +117,22 @@ typedef struct Target { /* * struct Master: * - * This record is used for two purposes: First, slaveTable (a hashtable) - * maps from names of commands to slave interpreters. This hashtable is - * used to store information about slave interpreters of this interpreter, - * to map over all slaves, etc. The second purpose is to store information - * about all aliases in slaves (or siblings) which direct to target commands - * in this interpreter (using the targetsPtr doubly-linked list). - * - * NB: the flags field in the interp structure, used with SAFE_INTERP - * mask denotes whether the interpreter is safe or not. Safe - * interpreters have restricted functionality, can only create safe slave - * interpreters and can only load safe extensions. + * This record is used for two purposes: First, slaveTable (a hashtable) maps + * from names of commands to slave interpreters. This hashtable is used to + * store information about slave interpreters of this interpreter, to map over + * all slaves, etc. The second purpose is to store information about all + * aliases in slaves (or siblings) which direct to target commands in this + * interpreter (using the targetsPtr doubly-linked list). + * + * NB: the flags field in the interp structure, used with SAFE_INTERP mask + * denotes whether the interpreter is safe or not. Safe interpreters have + * restricted functionality, can only create safe slave interpreters and can + * only load safe extensions. */ typedef struct Master { - Tcl_HashTable slaveTable; /* Hash table for slave interpreters. - * Maps from command names to Slave records. */ + Tcl_HashTable slaveTable; /* Hash table for slave interpreters. Maps + * from command names to Slave records. */ Target *targetsPtr; /* The head of a doubly-linked list of all the * target records which denote aliases from * slaves or sibling interpreters that direct @@ -154,10 +155,10 @@ typedef struct InterpInfo { } InterpInfo; /* - * Limit callbacks handled by scripts are modelled as structures which - * are stored in hashes indexed by a two-word key. Note that the type - * of the 'type' field in the key is not int; this is to make sure - * that things are likely to work properly on 64-bit architectures. + * Limit callbacks handled by scripts are modelled as structures which are + * stored in hashes indexed by a two-word key. Note that the type of the + * 'type' field in the key is not int; this is to make sure that things are + * likely to work properly on 64-bit architectures. */ struct ScriptLimitCallback { @@ -185,10 +186,10 @@ static int AliasDelete _ANSI_ARGS_((Tcl_Interp *interp, static int AliasDescribe _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr)); static int AliasList _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Interp *slaveInterp)); + Tcl_Interp *slaveInterp)); static int AliasObjCmd _ANSI_ARGS_((ClientData dummy, Tcl_Interp *currentInterp, int objc, - Tcl_Obj *CONST objv[])); + Tcl_Obj *CONST objv[])); static void AliasObjCmdDeleteProc _ANSI_ARGS_(( ClientData clientData)); @@ -202,7 +203,7 @@ static int SlaveBgerror _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); static Tcl_Interp * SlaveCreate _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *pathPtr, int safe)); + Tcl_Obj *pathPtr, int safe)); static int SlaveEval _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, Tcl_Obj *CONST objv[])); @@ -216,7 +217,7 @@ static int SlaveHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); static int SlaveInvokeHidden _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp, - CONST char *namespaceName, + CONST char *namespaceName, int objc, Tcl_Obj *CONST objv[])); static int SlaveMarkTrusted _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Interp *slaveInterp)); @@ -254,8 +255,8 @@ static void TimeLimitCallback _ANSI_ARGS_((ClientData clientData)); * * TclSetPreInitScript -- * - * This routine is used to change the value of the internal - * variable, tclPreInitScript. + * This routine is used to change the value of the internal variable, + * tclPreInitScript. * * Results: * Returns the current value of tclPreInitScript. @@ -280,69 +281,71 @@ TclSetPreInitScript (string) * * Tcl_Init -- * - * This procedure is typically invoked by Tcl_AppInit procedures - * to find and source the "init.tcl" script, which should exist - * somewhere on the Tcl library path. + * This procedure is typically invoked by Tcl_AppInit procedures to find + * and source the "init.tcl" script, which should exist somewhere on the + * Tcl library path. * * Results: - * Returns a standard Tcl completion code and sets the interp's - * result if there is an error. + * Returns a standard Tcl completion code and sets the interp's result if + * there is an error. * * Side effects: - * Depends on what's in the init.tcl script. + * Depends on what's in the init.tcl script. * *---------------------------------------------------------------------- */ int Tcl_Init(interp) - Tcl_Interp *interp; /* Interpreter to initialize. */ + Tcl_Interp *interp; /* Interpreter to initialize. */ { if (tclPreInitScript != NULL) { if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { return (TCL_ERROR); }; } -/* - * In order to find init.tcl during initialization, the following script - * is invoked by Tcl_Init(). It looks in several different directories: - * - * $tcl_library - can specify a primary location, if set, - * no other locations will be checked. This - * is the recommended way for a program that - * embeds Tcl to specifically tell Tcl where - * to find an init.tcl file. - * - * $env(TCL_LIBRARY) - highest priority so user can always override - * the search path unless the application has - * specified an exact directory above - * - * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl - * on those platforms where it can determine - * at runtime the directory where it expects - * the init.tcl file to be. After [tclInit] - * reads and uses this value, it [unset]s it. - * External users of Tcl should not make use - * of the variable to customize [tclInit]. - * - * $tcl_libPath - OBSOLETE: This variable is no longer - * set by Tcl itself, but [tclInit] examines - * it in case some program that embeds Tcl - * is customizing [tclInit] by setting this - * variable to a list of directories in which - * to search. - * - * [tcl::pkgconfig get scriptdir,runtime] - * - the directory determined by configure to - * be the place where Tcl's script library - * is to be installed. - * - * The first directory on this path that contains a valid init.tcl script - * will be set as the value of tcl_library. - * - * Note that this entire search mechanism can be bypassed by defining an - * alternate tclInit procedure before calling Tcl_Init(). - */ + + /* + * In order to find init.tcl during initialization, the following script + * is invoked by Tcl_Init(). It looks in several different directories: + * + * $tcl_library - can specify a primary location, if set, no + * other locations will be checked. This is + * the recommended way for a program that + * embeds Tcl to specifically tell Tcl where to + * find an init.tcl file. + * + * $env(TCL_LIBRARY) - highest priority so user can always override + * the search path unless the application has + * specified an exact directory above + * + * $tclDefaultLibrary - INTERNAL: This variable is set by Tcl + * on those platforms where it can determine at + * runtime the directory where it expects the + * init.tcl file to be. After [tclInit] reads + * and uses this value, it [unset]s it. + * External users of Tcl should not make use of + * the variable to customize [tclInit]. + * + * $tcl_libPath - OBSOLETE: This variable is no longer + * set by Tcl itself, but [tclInit] examines it + * in case some program that embeds Tcl is + * customizing [tclInit] by setting this + * variable to a list of directories in which + * to search. + * + * [tcl::pkgconfig get scriptdir,runtime] + * - the directory determined by configure to be + * the place where Tcl's script library is to + * be installed. + * + * The first directory on this path that contains a valid init.tcl script + * will be set as the value of tcl_library. + * + * Note that this entire search mechanism can be bypassed by defining an + * alternate tclInit procedure before calling Tcl_Init(). + */ + return Tcl_Eval(interp, "if {[info proc tclInit]==\"\"} {\n" " proc tclInit {} {\n" @@ -413,8 +416,8 @@ Tcl_Init(interp) * * TclInterpInit -- * - * Initializes the invoking interpreter for using the master, slave - * and safe interp facilities. This is called from inside + * Initializes the invoking interpreter for using the master, slave and + * safe interp facilities. This is called from inside * Tcl_CreateInterp(). * * Results: @@ -433,7 +436,7 @@ TclInterpInit(interp) { InterpInfo *interpInfoPtr; Master *masterPtr; - Slave *slavePtr; + Slave *slavePtr; interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = (ClientData) interpInfoPtr; @@ -460,15 +463,14 @@ TclInterpInit(interp) * * InterpInfoDeleteProc -- * - * Invoked when an interpreter is being deleted. It releases all - * storage used by the master/slave/safe interpreter facilities. + * Invoked when an interpreter is being deleted. It releases all storage + * used by the master/slave/safe interpreter facilities. * * Results: * None. * * Side effects: - * Cleans up storage. Sets the interpInfoPtr field of the interp - * to NULL. + * Cleans up storage. Sets the interpInfoPtr field of the interp to NULL. * *--------------------------------------------------------------------------- */ @@ -476,7 +478,7 @@ TclInterpInit(interp) static void InterpInfoDeleteProc(clientData, interp) ClientData clientData; /* Ignored. */ - Tcl_Interp *interp; /* Interp being deleted. All commands for + Tcl_Interp *interp; /* Interp being deleted. All commands for * slave interps should already be deleted. */ { InterpInfo *interpInfoPtr; @@ -498,8 +500,8 @@ InterpInfoDeleteProc(clientData, interp) /* * Tell any interps that have aliases to this interp that they should - * delete those aliases. If the other interp was already dead, it - * would have removed the target record already. + * delete those aliases. If the other interp was already dead, it would + * have removed the target record already. */ for (targetPtr = masterPtr->targetsPtr; targetPtr != NULL; ) { @@ -512,14 +514,14 @@ InterpInfoDeleteProc(clientData, interp) slavePtr = &interpInfoPtr->slave; if (slavePtr->interpCmd != NULL) { /* - * Tcl_DeleteInterp() was called on this interpreter, rather - * "interp delete" or the equivalent deletion of the command in the - * master. First ensure that the cleanup callback doesn't try to - * delete the interp again. + * Tcl_DeleteInterp() was called on this interpreter, rather "interp + * delete" or the equivalent deletion of the command in the master. + * First ensure that the cleanup callback doesn't try to delete the + * interp again. */ slavePtr->slaveInterp = NULL; - Tcl_DeleteCommandFromToken(slavePtr->masterInterp, + Tcl_DeleteCommandFromToken(slavePtr->masterInterp, slavePtr->interpCmd); } @@ -532,7 +534,7 @@ InterpInfoDeleteProc(clientData, interp) } Tcl_DeleteHashTable(&slavePtr->aliasTable); - ckfree((char *) interpInfoPtr); + ckfree((char *) interpInfoPtr); } /* @@ -540,8 +542,8 @@ InterpInfoDeleteProc(clientData, interp) * * Tcl_InterpObjCmd -- * - * This procedure is invoked to process the "interp" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "interp" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -561,12 +563,12 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) { int index; static CONST char *options[] = { - "alias", "aliases", "bgerror", "create", + "alias", "aliases", "bgerror", "create", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit","slaves", "share", "target", "transfer", - NULL + NULL }; enum option { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE, @@ -576,456 +578,447 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) OPT_SHARE, OPT_TARGET, OPT_TRANSFER }; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum option) index) { - case OPT_ALIAS: { - Tcl_Interp *slaveInterp, *masterInterp; + case OPT_ALIAS: { + Tcl_Interp *slaveInterp, *masterInterp; - if (objc < 4) { - aliasArgs: - Tcl_WrongNumArgs(interp, 2, objv, - "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { + if (objc < 4) { + aliasArgs: + Tcl_WrongNumArgs(interp, 2, objv, + "slavePath slaveCmd ?masterPath masterCmd? ?args ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + if (objc == 4) { + return AliasDescribe(interp, slaveInterp, objv[3]); + } + if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { + return AliasDelete(interp, slaveInterp, objv[3]); + } + if (objc > 5) { + masterInterp = GetInterp(interp, objv[4]); + if (masterInterp == (Tcl_Interp *) NULL) { return TCL_ERROR; } - if (objc == 4) { - return AliasDescribe(interp, slaveInterp, objv[3]); - } - if ((objc == 5) && (Tcl_GetString(objv[4])[0] == '\0')) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - if (objc > 5) { - masterInterp = GetInterp(interp, objv[4]); - if (masterInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - if (Tcl_GetString(objv[5])[0] == '\0') { - if (objc == 6) { - return AliasDelete(interp, slaveInterp, objv[3]); - } - } else { - return AliasCreate(interp, slaveInterp, masterInterp, - objv[3], objv[5], objc - 6, objv + 6); + if (Tcl_GetString(objv[5])[0] == '\0') { + if (objc == 6) { + return AliasDelete(interp, slaveInterp, objv[3]); } + } else { + return AliasCreate(interp, slaveInterp, masterInterp, objv[3], + objv[5], objc - 6, objv + 6); } - goto aliasArgs; } - case OPT_ALIASES: { - Tcl_Interp *slaveInterp; + goto aliasArgs; + } + case OPT_ALIASES: { + Tcl_Interp *slaveInterp; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return AliasList(interp, slaveInterp); + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; } - case OPT_BGERROR: { - Tcl_Interp *slaveInterp; + return AliasList(interp, slaveInterp); + } + case OPT_BGERROR: { + Tcl_Interp *slaveInterp; - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?"); + return TCL_ERROR; } - case OPT_CREATE: { - int i, last, safe; - Tcl_Obj *slavePtr; - char buf[16 + TCL_INTEGER_SPACE]; - static CONST char *options[] = { - "-safe", "--", NULL - }; - enum option { - OPT_SAFE, OPT_LAST - }; - - safe = Tcl_IsSafe(interp); - - /* - * Weird historical rules: "-safe" is accepted at the end, too. - */ + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_CREATE: { + int i, last, safe; + Tcl_Obj *slavePtr; + char buf[16 + TCL_INTEGER_SPACE]; + static CONST char *options[] = { + "-safe", "--", NULL + }; + enum option { + OPT_SAFE, OPT_LAST + }; - slavePtr = NULL; - last = 0; - for (i = 2; i < objc; i++) { - if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", - 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_SAFE) { - safe = 1; - continue; - } - i++; - last = 1; - } - if (slavePtr != NULL) { - Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); + safe = Tcl_IsSafe(interp); + + /* + * Weird historical rules: "-safe" is accepted at the end, too. + */ + + slavePtr = NULL; + last = 0; + for (i = 2; i < objc; i++) { + if ((last == 0) && (Tcl_GetString(objv[i])[0] == '-')) { + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { return TCL_ERROR; } - if (i < objc) { - slavePtr = objv[i]; + if (index == OPT_SAFE) { + safe = 1; + continue; } + i++; + last = 1; } - buf[0] = '\0'; - if (slavePtr == NULL) { - /* - * Create an anonymous interpreter -- we choose its name and - * the name of the command. We check that the command name - * that we use for the interpreter does not collide with an - * existing command in the master interpreter. - */ - - for (i = 0; ; i++) { - Tcl_CmdInfo cmdInfo; - - sprintf(buf, "interp%d", i); - if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { - break; - } - } - slavePtr = Tcl_NewStringObj(buf, -1); - } - if (SlaveCreate(interp, slavePtr, safe) == NULL) { - if (buf[0] != '\0') { - Tcl_DecrRefCount(slavePtr); - } + if (slavePtr != NULL) { + Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?"); return TCL_ERROR; } - Tcl_SetObjResult(interp, slavePtr); - return TCL_OK; - } - case OPT_DELETE: { - int i; - InterpInfo *iiPtr; - Tcl_Interp *slaveInterp; - - for (i = 2; i < objc; i++) { - slaveInterp = GetInterp(interp, objv[i]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } else if (slaveInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot delete the current interpreter", -1)); - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, - iiPtr->slave.interpCmd); + if (i < objc) { + slavePtr = objv[i]; } - return TCL_OK; } - case OPT_EVAL: { - Tcl_Interp *slaveInterp; + buf[0] = '\0'; + if (slavePtr == NULL) { + /* + * Create an anonymous interpreter -- we choose its name and the + * name of the command. We check that the command name that we use + * for the interpreter does not collide with an existing command + * in the master interpreter. + */ - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); - } - case OPT_EXISTS: { - int exists; - Tcl_Interp *slaveInterp; + for (i = 0; ; i++) { + Tcl_CmdInfo cmdInfo; - exists = 1; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - if (objc > 3) { - return TCL_ERROR; + sprintf(buf, "interp%d", i); + if (Tcl_GetCommandInfo(interp, buf, &cmdInfo) == 0) { + break; } - Tcl_ResetResult(interp); - exists = 0; } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); - return TCL_OK; + slavePtr = Tcl_NewStringObj(buf, -1); } - case OPT_EXPOSE: { - Tcl_Interp *slaveInterp; - - if ((objc < 4) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path hiddenCmdName ?cmdName?"); - return TCL_ERROR; + if (SlaveCreate(interp, slavePtr, safe) == NULL) { + if (buf[0] != '\0') { + Tcl_DecrRefCount(slavePtr); } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + return TCL_ERROR; } - case OPT_HIDE: { - Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_SetObjResult(interp, slavePtr); + return TCL_OK; + } + case OPT_DELETE: { + int i; + InterpInfo *iiPtr; + Tcl_Interp *slaveInterp; - if ((objc < 4) || (objc > 5)) { - Tcl_WrongNumArgs(interp, 2, objv, - "path cmdName ?hiddenCmdName?"); + for (i = 2; i < objc; i++) { + slaveInterp = GetInterp(interp, objv[i]); + if (slaveInterp == NULL) { return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { + } else if (slaveInterp == interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot delete the current interpreter", -1)); return TCL_ERROR; } - return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + Tcl_DeleteCommandFromToken(iiPtr->slave.masterInterp, + iiPtr->slave.interpCmd); } - case OPT_HIDDEN: { - Tcl_Interp *slaveInterp; /* A slave. */ + return TCL_OK; + } + case OPT_EVAL: { + Tcl_Interp *slaveInterp; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveEval(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_EXISTS: { + int exists; + Tcl_Interp *slaveInterp; + + exists = 1; + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + if (objc > 3) { return TCL_ERROR; } - return SlaveHidden(interp, slaveInterp); + Tcl_ResetResult(interp); + exists = 0; } - case OPT_ISSAFE: { - Tcl_Interp *slaveInterp; + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; + } + case OPT_EXPOSE: { + Tcl_Interp *slaveInterp; - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDE: { + Tcl_Interp *slaveInterp; /* A slave. */ + + if ((objc < 4) || (objc > 5)) { + Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; + } + return SlaveHide(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_HIDDEN: { + Tcl_Interp *slaveInterp; /* A slave. */ + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveHidden(interp, slaveInterp); + } + case OPT_ISSAFE: { + Tcl_Interp *slaveInterp; + + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; + } + case OPT_INVOKEHID: { + int i, index; + CONST char *namespaceName; + Tcl_Interp *slaveInterp; + static CONST char *hiddenOptions[] = { + "-global", "-namespace", "--", NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; + + namespaceName = NULL; + for (i = 3; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; - } - case OPT_INVOKEHID: { - int i, index; - CONST char *namespaceName; - Tcl_Interp *slaveInterp; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 3; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_GLOBAL) { - namespaceName = "::"; } else { - if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ - break; - } else { - namespaceName = Tcl_GetString(objv[i]); - } - } else { - i++; - break; - } + namespaceName = Tcl_GetString(objv[i]); } + } else { + i++; + break; } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 2, objv, - "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == (Tcl_Interp *) NULL) { - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, - objc - i, objv + i); } - case OPT_LIMIT: { - Tcl_Interp *slaveInterp; - static CONST char *limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", - 0, &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); - } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "path ?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == (Tcl_Interp *) NULL) { + return TCL_ERROR; } - case OPT_MARKTRUSTED: { - Tcl_Interp *slaveInterp; + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc - i, + objv + i); + } + case OPT_LIMIT: { + Tcl_Interp *slaveInterp; + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "path"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); + if (objc < 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path limitType ?options?"); + return TCL_ERROR; } - case OPT_RECLIMIT: { - Tcl_Interp *slaveInterp; + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[3], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 4, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv); + } + } + case OPT_MARKTRUSTED: { + Tcl_Interp *slaveInterp; - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "path"); + return TCL_ERROR; } - case OPT_SLAVES: { - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_Obj *resultPtr; - Tcl_HashEntry *hPtr; - Tcl_HashSearch hashSearch; - char *string; - - slaveInterp = GetInterp2(interp, objc, objv); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - resultPtr = Tcl_NewObj(); - hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); - for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { - string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewStringObj(string, -1)); - } - Tcl_SetObjResult(interp, resultPtr); - return TCL_OK; + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; } - case OPT_SHARE: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; + return SlaveMarkTrusted(interp, slaveInterp); + } + case OPT_RECLIMIT: { + Tcl_Interp *slaveInterp; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), - NULL); - if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - return TCL_OK; + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?"); + return TCL_ERROR; } - case OPT_TARGET: { - Tcl_Interp *slaveInterp; - InterpInfo *iiPtr; - Tcl_HashEntry *hPtr; - Alias *aliasPtr; - char *aliasName; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "path alias"); - return TCL_ERROR; - } + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3); + } + case OPT_SLAVES: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_Obj *resultPtr; + Tcl_HashEntry *hPtr; + Tcl_HashSearch hashSearch; + char *string; - slaveInterp = GetInterp(interp, objv[2]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } + slaveInterp = GetInterp2(interp, objc, objv); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + resultPtr = Tcl_NewObj(); + hPtr = Tcl_FirstHashEntry(&iiPtr->master.slaveTable, &hashSearch); + for ( ; hPtr != NULL; hPtr = Tcl_NextHashEntry(&hashSearch)) { + string = Tcl_GetHashKey(&iiPtr->master.slaveTable, hPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, + Tcl_NewStringObj(string, -1)); + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + } + case OPT_SHARE: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; - aliasName = Tcl_GetString(objv[3]); + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + return TCL_OK; + } + case OPT_TARGET: { + Tcl_Interp *slaveInterp; + InterpInfo *iiPtr; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + char *aliasName; + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "path alias"); + return TCL_ERROR; + } - iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); - if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, - "\" in path \"", Tcl_GetString(objv[2]), - "\" not found", (char *) NULL); - return TCL_ERROR; - } - aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); - if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "target interpreter for alias \"", - aliasName, "\" in path \"", Tcl_GetString(objv[2]), - "\" is not my descendant", (char *) NULL); - return TCL_ERROR; - } - return TCL_OK; + slaveInterp = GetInterp(interp, objv[2]); + if (slaveInterp == NULL) { + return TCL_ERROR; } - case OPT_TRANSFER: { - Tcl_Interp *slaveInterp; /* A slave. */ - Tcl_Interp *masterInterp; /* Its master. */ - Tcl_Channel chan; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, - "srcPath channelId destPath"); - return TCL_ERROR; - } - masterInterp = GetInterp(interp, objv[2]); - if (masterInterp == NULL) { - return TCL_ERROR; - } - chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); - if (chan == NULL) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - slaveInterp = GetInterp(interp, objv[4]); - if (slaveInterp == NULL) { - return TCL_ERROR; - } - Tcl_RegisterChannel(slaveInterp, chan); - if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { - TclTransferResult(masterInterp, TCL_OK, interp); - return TCL_ERROR; - } - return TCL_OK; + + aliasName = Tcl_GetString(objv[3]); + + iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo; + hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_AppendResult(interp, "alias \"", aliasName, "\" in path \"", + Tcl_GetString(objv[2]), "\" not found", (char *) NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); + if (Tcl_GetInterpPath(interp, aliasPtr->targetInterp) != TCL_OK) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "target interpreter for alias \"", + aliasName, "\" in path \"", Tcl_GetString(objv[2]), + "\" is not my descendant", (char *) NULL); + return TCL_ERROR; + } + return TCL_OK; + } + case OPT_TRANSFER: { + Tcl_Interp *slaveInterp; /* A slave. */ + Tcl_Interp *masterInterp; /* Its master. */ + Tcl_Channel chan; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath"); + return TCL_ERROR; + } + masterInterp = GetInterp(interp, objv[2]); + if (masterInterp == NULL) { + return TCL_ERROR; + } + chan = Tcl_GetChannel(masterInterp, Tcl_GetString(objv[3]), NULL); + if (chan == NULL) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; + } + slaveInterp = GetInterp(interp, objv[4]); + if (slaveInterp == NULL) { + return TCL_ERROR; + } + Tcl_RegisterChannel(slaveInterp, chan); + if (Tcl_UnregisterChannel(masterInterp, chan) != TCL_OK) { + TclTransferResult(masterInterp, TCL_OK, interp); + return TCL_ERROR; } + return TCL_OK; + } } return TCL_OK; } @@ -1039,18 +1032,18 @@ Tcl_InterpObjCmd(clientData, interp, objc, objv) * potentially specified on the command line to an Tcl_Interp. * * Results: - * The return value is the interp specified on the command line, - * or the interp argument itself if no interp was specified on the - * command line. If the interp could not be found or the wrong - * number of arguments was specified on the command line, the return - * value is NULL and an error message is left in the interp's result. + * The return value is the interp specified on the command line, or the + * interp argument itself if no interp was specified on the command line. + * If the interp could not be found or the wrong number of arguments was + * specified on the command line, the return value is NULL and an error + * message is left in the interp's result. * * Side effects: * None. * *--------------------------------------------------------------------------- */ - + static Tcl_Interp * GetInterp2(interp, objc, objv) Tcl_Interp *interp; /* Default interp if no interp was specified @@ -1097,13 +1090,13 @@ Tcl_CreateAlias(slaveInterp, slaveCmd, targetInterp, targetCmd, argc, argv) Tcl_Obj **objv; int i; int result; - + objv = (Tcl_Obj **) ckalloc((unsigned) sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { - objv[i] = Tcl_NewStringObj(argv[i], -1); - Tcl_IncrRefCount(objv[i]); + objv[i] = Tcl_NewStringObj(argv[i], -1); + Tcl_IncrRefCount(objv[i]); } - + slaveObjPtr = Tcl_NewStringObj(slaveCmd, -1); Tcl_IncrRefCount(slaveObjPtr); @@ -1173,7 +1166,7 @@ Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) * Gets information about an alias. * * Results: - * A standard Tcl result. + * A standard Tcl result. * * Side effects: * None. @@ -1183,9 +1176,9 @@ Tcl_CreateAliasObj(slaveInterp, slaveCmd, targetInterp, targetCmd, objc, objv) int Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, - argvPtr) + argvPtr) Tcl_Interp *interp; /* Interp to start search from. */ - CONST char *aliasName; /* Name of alias to find. */ + CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ CONST char **targetNamePtr; /* (Return) name of target command. */ int *argcPtr; /* (Return) count of addnl args. */ @@ -1196,11 +1189,11 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, Alias *aliasPtr; int i, objc; Tcl_Obj **objv; - + iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", (char *) NULL); return TCL_ERROR; } @@ -1218,11 +1211,11 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, *argcPtr = objc - 1; } if (argvPtr != NULL) { - *argvPtr = (CONST char **) + *argvPtr = (CONST char **) ckalloc((unsigned) sizeof(CONST char *) * (objc - 1)); - for (i = 1; i < objc; i++) { - *argvPtr[i - 1] = Tcl_GetString(objv[i]); - } + for (i = 1; i < objc; i++) { + *argvPtr[i - 1] = Tcl_GetString(objv[i]); + } } return TCL_OK; } @@ -1245,7 +1238,7 @@ Tcl_GetAlias(interp, aliasName, targetInterpPtr, targetNamePtr, argcPtr, int Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, - objvPtr) + objvPtr) Tcl_Interp *interp; /* Interp to start search from. */ CONST char *aliasName; /* Name of alias to find. */ Tcl_Interp **targetInterpPtr; /* (Return) target interpreter. */ @@ -1255,32 +1248,32 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, { InterpInfo *iiPtr; Tcl_HashEntry *hPtr; - Alias *aliasPtr; + Alias *aliasPtr; int objc; Tcl_Obj **objv; iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; hPtr = Tcl_FindHashEntry(&iiPtr->slave.aliasTable, aliasName); if (hPtr == (Tcl_HashEntry *) NULL) { - Tcl_AppendResult(interp, "alias \"", aliasName, - "\" not found", (char *) NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "alias \"", aliasName, "\" not found", + (char *) NULL); + return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); objc = aliasPtr->objc; objv = &aliasPtr->objPtr; if (targetInterpPtr != (Tcl_Interp **) NULL) { - *targetInterpPtr = aliasPtr->targetInterp; + *targetInterpPtr = aliasPtr->targetInterp; } if (targetNamePtr != (CONST char **) NULL) { - *targetNamePtr = Tcl_GetString(objv[0]); + *targetNamePtr = Tcl_GetString(objv[0]); } if (objcPtr != (int *) NULL) { - *objcPtr = objc - 1; + *objcPtr = objc - 1; } if (objvPtr != (Tcl_Obj ***) NULL) { - *objvPtr = objv + 1; + *objvPtr = objv + 1; } return TCL_OK; } @@ -1290,19 +1283,19 @@ Tcl_GetAliasObj(interp, aliasName, targetInterpPtr, targetNamePtr, objcPtr, * * TclPreventAliasLoop -- * - * When defining an alias or renaming a command, prevent an alias - * loop from being formed. + * When defining an alias or renaming a command, prevent an alias loop + * from being formed. * * Results: * A standard Tcl object result. * * Side effects: - * If TCL_ERROR is returned, the function also stores an error message - * in the interpreter's result object. + * If TCL_ERROR is returned, the function also stores an error message in + * the interpreter's result object. * * NOTE: - * This function is public internal (instead of being static to - * this file) because it is also used from TclRenameCommand. + * This function is public internal (instead of being static to this + * file) because it is also used from TclRenameCommand. * *---------------------------------------------------------------------- */ @@ -1311,9 +1304,9 @@ int TclPreventAliasLoop(interp, cmdInterp, cmd) Tcl_Interp *interp; /* Interp in which to report errors. */ Tcl_Interp *cmdInterp; /* Interp in which the command is - * being defined. */ - Tcl_Command cmd; /* Tcl command we are attempting - * to define. */ + * being defined. */ + Tcl_Command cmd; /* Tcl command we are attempting to + * define. */ { Command *cmdPtr = (Command *) cmd; Alias *aliasPtr, *nextAliasPtr; @@ -1321,18 +1314,18 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) Command *aliasCmdPtr; /* - * If we are not creating or renaming an alias, then it is - * always OK to create or rename the command. + * If we are not creating or renaming an alias, then it is always OK to + * create or rename the command. */ - + if (cmdPtr->objProc != AliasObjCmd) { - return TCL_OK; + return TCL_OK; } /* - * OK, we are dealing with an alias, so traverse the chain of aliases. - * If we encounter the alias we are defining (or renaming to) any in - * the chain then we have a loop. + * OK, we are dealing with an alias, so traverse the chain of aliases. If + * we encounter the alias we are defining (or renaming to) any in the + * chain then we have a loop. */ aliasPtr = (Alias *) cmdPtr->objClientData; @@ -1340,9 +1333,9 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) while (1) { Tcl_Obj *cmdNamePtr; - /* - * If the target of the next alias in the chain is the same as - * the source alias, we have a loop. + /* + * If the target of the next alias in the chain is the same as the + * source alias, we have a loop. */ if (Tcl_InterpDeleted(nextAliasPtr->targetInterp)) { @@ -1358,30 +1351,30 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) } cmdNamePtr = nextAliasPtr->objPtr; aliasCmd = Tcl_FindCommand(nextAliasPtr->targetInterp, - Tcl_GetString(cmdNamePtr), + Tcl_GetString(cmdNamePtr), Tcl_GetGlobalNamespace(nextAliasPtr->targetInterp), /*flags*/ 0); - if (aliasCmd == (Tcl_Command) NULL) { - return TCL_OK; - } + if (aliasCmd == (Tcl_Command) NULL) { + return TCL_OK; + } aliasCmdPtr = (Command *) aliasCmd; - if (aliasCmdPtr == cmdPtr) { - Tcl_AppendResult(interp, "cannot define or rename alias \"", + if (aliasCmdPtr == cmdPtr) { + Tcl_AppendResult(interp, "cannot define or rename alias \"", Tcl_GetCommandName(cmdInterp, cmd), "\": would create a loop", (char *) NULL); - return TCL_ERROR; - } + return TCL_ERROR; + } - /* + /* * Otherwise, follow the chain one step further. See if the target - * command is an alias - if so, follow the loop to its target - * command. Otherwise we do not have a loop. + * command is an alias - if so, follow the loop to its target command. + * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { - return TCL_OK; - } - nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; + if (aliasCmdPtr->objProc != AliasObjCmd) { + return TCL_OK; + } + nextAliasPtr = (Alias *) aliasCmdPtr->objClientData; } /* NOTREACHED */ @@ -1398,8 +1391,8 @@ TclPreventAliasLoop(interp, cmdInterp, cmd) * A standard Tcl result. * * Side effects: - * An alias command is created and entered into the alias table - * for the slave interpreter. + * An alias command is created and entered into the alias table for the + * slave interpreter. * *---------------------------------------------------------------------- */ @@ -1425,8 +1418,8 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, Tcl_Obj **prefv; int new, i; - aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) - + objc * sizeof(Tcl_Obj *))); + aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias) + + objc * sizeof(Tcl_Obj *))); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = masterInterp; @@ -1451,20 +1444,20 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, if (TclPreventAliasLoop(interp, slaveInterp, aliasPtr->slaveCmd) != TCL_OK) { /* - * Found an alias loop! The last call to Tcl_CreateObjCommand made + * Found an alias loop! The last call to Tcl_CreateObjCommand made * the alias point to itself. Delete the command and its alias * record. Be careful to wipe out its client data first, so the * command doesn't try to delete itself. */ Command *cmdPtr; - + Tcl_DecrRefCount(aliasPtr->token); Tcl_DecrRefCount(targetNamePtr); for (i = 0; i < objc; i++) { Tcl_DecrRefCount(objv[i]); } - + cmdPtr = (Command *) aliasPtr->slaveCmd; cmdPtr->clientData = NULL; cmdPtr->deleteProc = NULL; @@ -1490,7 +1483,7 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, while (1) { Tcl_Obj *newToken; char *string; - + string = Tcl_GetString(aliasPtr->token); hPtr = Tcl_CreateHashEntry(&slavePtr->aliasTable, string, &new); if (new != 0) { @@ -1498,18 +1491,17 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, } /* - * The alias name cannot be used as unique token, it is already - * taken. We can produce a unique token by prepending "::" - * repeatedly. This algorithm is a stop-gap to try to maintain - * the command name as token for most use cases, fearful of - * possible backwards compat problems. A better algorithm would - * produce unique tokens that need not be related to the command - * name. + * The alias name cannot be used as unique token, it is already taken. + * We can produce a unique token by prepending "::" repeatedly. This + * algorithm is a stop-gap to try to maintain the command name as + * token for most use cases, fearful of possible backwards compat + * problems. A better algorithm would produce unique tokens that need + * not be related to the command name. * - * ATTENTION: the tests in interp.test and possibly safe.test - * depend on the precise definition of these tokens. + * ATTENTION: the tests in interp.test and possibly safe.test depend + * on the precise definition of these tokens. */ - + newToken = Tcl_NewStringObj("::",-1); Tcl_AppendObjToObj(newToken, aliasPtr->token); Tcl_DecrRefCount(aliasPtr->token); @@ -1519,7 +1511,7 @@ AliasCreate(interp, slaveInterp, masterInterp, namePtr, targetNamePtr, aliasPtr->aliasEntryPtr = hPtr; Tcl_SetHashValue(hPtr, (ClientData) aliasPtr); - + /* * Create the new command. We must do it after deleting any old command, * because the alias may be pointing at a renamed alias, as in: @@ -1584,9 +1576,9 @@ AliasDelete(interp, slaveInterp, namePtr) slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { - Tcl_AppendResult(interp, "alias \"", - Tcl_GetString(namePtr), "\" not found", NULL); - return TCL_ERROR; + Tcl_AppendResult(interp, "alias \"", Tcl_GetString(namePtr), + "\" not found", NULL); + return TCL_ERROR; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd); @@ -1598,10 +1590,9 @@ AliasDelete(interp, slaveInterp, namePtr) * * AliasDescribe -- * - * Sets the interpreter's result object to a Tcl list describing - * the given alias in the given interpreter: its target command - * and the additional arguments to prepend to any invocation - * of the alias. + * Sets the interpreter's result object to a Tcl list describing the + * given alias in the given interpreter: its target command and the + * additional arguments to prepend to any invocation of the alias. * * Results: * A standard Tcl result. @@ -1620,7 +1611,7 @@ AliasDescribe(interp, slaveInterp, namePtr) { Slave *slavePtr; Tcl_HashEntry *hPtr; - Alias *aliasPtr; + Alias *aliasPtr; Tcl_Obj *prefixPtr; /* @@ -1632,7 +1623,7 @@ AliasDescribe(interp, slaveInterp, namePtr) slavePtr = &((InterpInfo *) ((Interp *) slaveInterp)->interpInfo)->slave; hPtr = Tcl_FindHashEntry(&slavePtr->aliasTable, Tcl_GetString(namePtr)); if (hPtr == NULL) { - return TCL_OK; + return TCL_OK; } aliasPtr = (Alias *) Tcl_GetHashValue(hPtr); prefixPtr = Tcl_NewListObj(aliasPtr->objc, &aliasPtr->objPtr); @@ -1671,8 +1662,8 @@ AliasList(interp, slaveInterp) entryPtr = Tcl_FirstHashEntry(&slavePtr->aliasTable, &hashSearch); for ( ; entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&hashSearch)) { - aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); - Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); + aliasPtr = (Alias *) Tcl_GetHashValue(entryPtr); + Tcl_ListObjAppendElement(NULL, resultPtr, aliasPtr->token); } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; @@ -1683,19 +1674,19 @@ AliasList(interp, slaveInterp) * * AliasObjCmd -- * - * This is the procedure that services invocations of aliases in a - * slave interpreter. One such command exists for each alias. When - * invoked, this procedure redirects the invocation to the target - * command in the master interpreter as designated by the Alias - * record associated with this command. + * This is the procedure that services invocations of aliases in a slave + * interpreter. One such command exists for each alias. When invoked, + * this procedure redirects the invocation to the target command in the + * master interpreter as designated by the Alias record associated with + * this command. * * Results: * A standard Tcl result. * * Side effects: - * Causes forwarding of the invocation; all possible side effects - * may occur as a result of invoking the command to which the - * invocation is forwarded. + * Causes forwarding of the invocation; all possible side effects may + * occur as a result of invoking the command to which the invocation is + * forwarded. * *---------------------------------------------------------------------- */ @@ -1705,11 +1696,11 @@ AliasObjCmd(clientData, interp, objc, objv) ClientData clientData; /* Alias record. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument vector. */ + Tcl_Obj *CONST objv[]; /* Argument vector. */ { #define ALIAS_CMDV_PREALLOC 10 - Tcl_Interp *targetInterp; - Alias *aliasPtr; + Tcl_Interp *targetInterp; + Alias *aliasPtr; int result, prefc, cmdc, i; Tcl_Obj **prefv, **cmdv; Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; @@ -1717,10 +1708,10 @@ AliasObjCmd(clientData, interp, objc, objv) targetInterp = aliasPtr->targetInterp; /* - * Append the arguments to the command prefix and invoke the command - * in the target interp's global namespace. + * Append the arguments to the command prefix and invoke the command in + * the target interp's global namespace. */ - + prefc = aliasPtr->objc; prefv = &aliasPtr->objPtr; cmdc = prefc + objc - 1; @@ -1731,9 +1722,9 @@ AliasObjCmd(clientData, interp, objc, objv) } prefv = &aliasPtr->objPtr; - memcpy((VOID *) cmdv, (VOID *) prefv, - (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), + memcpy((VOID *) cmdv, (VOID *) prefv, + (size_t) (prefc * sizeof(Tcl_Obj *))); + memcpy((VOID *) (cmdv+prefc), (VOID *) (objv+1), (size_t) ((objc-1) * sizeof(Tcl_Obj *))); Tcl_ResetResult(targetInterp); @@ -1744,7 +1735,7 @@ AliasObjCmd(clientData, interp, objc, objv) if (targetInterp != interp) { Tcl_Preserve((ClientData) targetInterp); result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); - TclTransferResult(targetInterp, result, interp); + TclTransferResult(targetInterp, result, interp); Tcl_Release((ClientData) targetInterp); } else { result = Tcl_EvalObjv(targetInterp, cmdc, cmdv, TCL_EVAL_INVOKE); @@ -1756,7 +1747,7 @@ AliasObjCmd(clientData, interp, objc, objv) if (cmdv != cmdArr) { ckfree((char *) cmdv); } - return result; + return result; #undef ALIAS_CMDV_PREALLOC } @@ -1765,15 +1756,15 @@ AliasObjCmd(clientData, interp, objc, objv) * * AliasObjCmdDeleteProc -- * - * Is invoked when an alias command is deleted in a slave. Cleans up - * all storage associated with this alias. + * Is invoked when an alias command is deleted in a slave. Cleans up all + * storage associated with this alias. * * Results: * None. * * Side effects: - * Deletes the alias record and its entry in the alias table for - * the interpreter. + * Deletes the alias record and its entry in the alias table for the + * interpreter. * *---------------------------------------------------------------------- */ @@ -1782,13 +1773,13 @@ static void AliasObjCmdDeleteProc(clientData) ClientData clientData; /* The alias record for this alias. */ { - Alias *aliasPtr; - Target *targetPtr; + Alias *aliasPtr; + Target *targetPtr; int i; Tcl_Obj **objv; aliasPtr = (Alias *) clientData; - + Tcl_DecrRefCount(aliasPtr->token); objv = &aliasPtr->objPtr; for (i = 0; i < aliasPtr->objc; i++) { @@ -1821,20 +1812,20 @@ AliasObjCmdDeleteProc(clientData) * * Tcl_CreateSlave -- * - * Creates a slave interpreter. The slavePath argument denotes the - * name of the new slave relative to the current interpreter; the - * slave is a direct descendant of the one-before-last component of - * the path, e.g. it is a descendant of the current interpreter if - * the slavePath argument contains only one component. Optionally makes - * the slave interpreter safe. + * Creates a slave interpreter. The slavePath argument denotes the name + * of the new slave relative to the current interpreter; the slave is a + * direct descendant of the one-before-last component of the path, + * e.g. it is a descendant of the current interpreter if the slavePath + * argument contains only one component. Optionally makes the slave + * interpreter safe. * * Results: * Returns the interpreter structure created, or NULL if an error * occurred. * * Side effects: - * Creates a new interpreter and a new interpreter object command in - * the interpreter indicated by the slavePath argument. + * Creates a new interpreter and a new interpreter object command in the + * interpreter indicated by the slavePath argument. * *---------------------------------------------------------------------- */ @@ -1863,8 +1854,7 @@ Tcl_CreateSlave(interp, slavePath, isSafe) * Finds a slave interpreter by its path name. * * Results: - * Returns a Tcl_Interp * for the named interpreter or NULL if not - * found. + * Returns a Tcl_Interp * for the named interpreter or NULL if not found. * * Side effects: * None. @@ -1910,7 +1900,7 @@ Tcl_GetMaster(interp) Slave *slavePtr; /* Slave record of this interpreter. */ if (interp == (Tcl_Interp *) NULL) { - return NULL; + return NULL; } slavePtr = &((InterpInfo *) ((Interp *) interp)->interpInfo)->slave; return slavePtr->masterInterp; @@ -1922,19 +1912,17 @@ Tcl_GetMaster(interp) * Tcl_GetInterpPath -- * * Sets the result of the asking interpreter to a proper Tcl list - * containing the names of interpreters between the asking and - * target interpreters. The target interpreter must be either the - * same as the asking interpreter or one of its slaves (including - * recursively). + * containing the names of interpreters between the asking and target + * interpreters. The target interpreter must be either the same as the + * asking interpreter or one of its slaves (including recursively). * * Results: - * TCL_OK if the target interpreter is the same as, or a descendant - * of, the asking interpreter; TCL_ERROR else. This way one can - * distinguish between the case where the asking and target interps - * are the same (an empty list is the result, and TCL_OK is returned) - * and when the target is not a descendant of the asking interpreter - * (in which case the Tcl result is an error message and the function - * returns TCL_ERROR). + * TCL_OK if the target interpreter is the same as, or a descendant of, + * the asking interpreter; TCL_ERROR else. This way one can distinguish + * between the case where the asking and target interps are the same (an + * empty list is the result, and TCL_OK is returned) and when the target + * is not a descendant of the asking interpreter (in which case the Tcl + * result is an error message and the function returns TCL_ERROR). * * Side effects: * None. @@ -1948,20 +1936,19 @@ Tcl_GetInterpPath(askingInterp, targetInterp) Tcl_Interp *targetInterp; /* Interpreter to find. */ { InterpInfo *iiPtr; - + if (targetInterp == askingInterp) { - return TCL_OK; + return TCL_OK; } if (targetInterp == NULL) { return TCL_ERROR; } iiPtr = (InterpInfo *) ((Interp *) targetInterp)->interpInfo; if (Tcl_GetInterpPath(askingInterp, iiPtr->slave.masterInterp) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - Tcl_AppendElement(askingInterp, - Tcl_GetHashKey(&iiPtr->master.slaveTable, - iiPtr->slave.slaveEntryPtr)); + Tcl_AppendElement(askingInterp, Tcl_GetHashKey(&iiPtr->master.slaveTable, + iiPtr->slave.slaveEntryPtr)); return TCL_OK; } @@ -1974,7 +1961,7 @@ Tcl_GetInterpPath(askingInterp, targetInterp) * * Results: * Returns the slave interpreter known by that name in the calling - * interpreter, or NULL if no interpreter known by that name exists. + * interpreter, or NULL if no interpreter known by that name exists. * * Side effects: * Assigns to the pointer variable passed in, if not NULL. @@ -1985,13 +1972,13 @@ Tcl_GetInterpPath(askingInterp, targetInterp) static Tcl_Interp * GetInterp(interp, pathPtr) Tcl_Interp *interp; /* Interp. to start search from. */ - Tcl_Obj *pathPtr; /* List object containing name of interp. to + Tcl_Obj *pathPtr; /* List object containing name of interp. to * be found. */ { Tcl_HashEntry *hPtr; /* Search element. */ Slave *slavePtr; /* Interim slave record. */ Tcl_Obj **objv; - int objc, i; + int objc, i; Tcl_Interp *searchInterp; /* Interim storage for interp. to find. */ InterpInfo *masterInfoPtr; @@ -2002,21 +1989,21 @@ GetInterp(interp, pathPtr) searchInterp = interp; for (i = 0; i < objc; i++) { masterInfoPtr = (InterpInfo *) ((Interp *) searchInterp)->interpInfo; - hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, + hPtr = Tcl_FindHashEntry(&masterInfoPtr->master.slaveTable, Tcl_GetString(objv[i])); - if (hPtr == NULL) { + if (hPtr == NULL) { searchInterp = NULL; break; } - slavePtr = (Slave *) Tcl_GetHashValue(hPtr); - searchInterp = slavePtr->slaveInterp; - if (searchInterp == NULL) { + slavePtr = (Slave *) Tcl_GetHashValue(hPtr); + searchInterp = slavePtr->slaveInterp; + if (searchInterp == NULL) { break; } } if (searchInterp == NULL) { Tcl_AppendResult(interp, "could not find interpreter \"", - Tcl_GetString(pathPtr), "\"", (char *) NULL); + Tcl_GetString(pathPtr), "\"", (char *) NULL); } return searchInterp; } @@ -2026,15 +2013,15 @@ GetInterp(interp, pathPtr) * * SlaveBgerror -- * - * Helper function to set/query the background error handling - * command prefix of an interp + * Helper function to set/query the background error handling command + * prefix of an interp * * Results: * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new background - * handler of objv[0]. + * When (objc == 1), slaveInterp will be set to a new background handler + * of objv[0]. * *---------------------------------------------------------------------- */ @@ -2049,7 +2036,7 @@ SlaveBgerror(interp, slaveInterp, objc, objv) if (objc) { int length; - if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) + if (TCL_ERROR == Tcl_ListObjLength(NULL, objv[0], &length) || (length < 1)) { Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1", (char *) NULL); @@ -2066,9 +2053,9 @@ SlaveBgerror(interp, slaveInterp, objc, objv) * * SlaveCreate -- * - * Helper function to do the actual work of creating a slave interp - * and new object command. Also optionally makes the new slave - * interpreter "safe". + * Helper function to do the actual work of creating a slave interp and + * new object command. Also optionally makes the new slave interpreter + * "safe". * * Results: * Returns the new Tcl_Interp * if successful or NULL if not. If failed, @@ -2093,8 +2080,6 @@ SlaveCreate(interp, pathPtr, safe) char *path; int new, objc; Tcl_Obj **objv; - Tcl_Obj* clockObj; - int status; if (Tcl_ListObjGetElements(interp, pathPtr, &objc, &objv) != TCL_OK) { return NULL; @@ -2104,7 +2089,7 @@ SlaveCreate(interp, pathPtr, safe) path = Tcl_GetString(pathPtr); } else { Tcl_Obj *objPtr; - + objPtr = Tcl_NewListObj(objc - 1, objv); masterInterp = GetInterp(interp, objPtr); Tcl_DecrRefCount(objPtr); @@ -2120,9 +2105,9 @@ SlaveCreate(interp, pathPtr, safe) masterInfoPtr = (InterpInfo *) ((Interp *) masterInterp)->interpInfo; hPtr = Tcl_CreateHashEntry(&masterInfoPtr->master.slaveTable, path, &new); if (new == 0) { - Tcl_AppendResult(interp, "interpreter named \"", path, + Tcl_AppendResult(interp, "interpreter named \"", path, "\" already exists, cannot create", (char *) NULL); - return NULL; + return NULL; } slaveInterp = Tcl_CreateInterp(); @@ -2131,48 +2116,53 @@ SlaveCreate(interp, pathPtr, safe) slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); + SlaveObjCmd, (ClientData) slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, (ClientData) slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); - + /* * Inherit the recursion limit. */ + ((Interp *) slaveInterp)->maxNestingDepth = - ((Interp *) masterInterp)->maxNestingDepth ; + ((Interp *) masterInterp)->maxNestingDepth; if (safe) { - if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { - goto error; - } + if (Tcl_MakeSafe(slaveInterp) == TCL_ERROR) { + goto error; + } } else { - if (Tcl_Init(slaveInterp) == TCL_ERROR) { - goto error; - } + if (Tcl_Init(slaveInterp) == TCL_ERROR) { + goto error; + } + /* - * This will create the "memory" command in slave interpreters - * if we compiled with TCL_MEM_DEBUG, otherwise it does nothing. + * This will create the "memory" command in slave interpreters if we + * compiled with TCL_MEM_DEBUG, otherwise it does nothing. */ + Tcl_InitMemory(slaveInterp); } /* * Inherit the TIP#143 limits. */ + InheritLimitsFromMaster(slaveInterp, masterInterp); - if ( safe ) { - clockObj = Tcl_NewStringObj( "clock", -1 ); - Tcl_IncrRefCount( clockObj ); - status = AliasCreate( interp, slaveInterp, masterInterp, - clockObj, clockObj, 0, (Tcl_Obj *CONST *) NULL ); - Tcl_DecrRefCount( clockObj ); - if ( status != TCL_OK ) { + if (safe) { + Tcl_Obj* clockObj = Tcl_NewStringObj("clock", -1); + int status; + + Tcl_IncrRefCount(clockObj); + status = AliasCreate(interp, slaveInterp, masterInterp, clockObj, + clockObj, 0, (Tcl_Obj *CONST *) NULL); + Tcl_DecrRefCount(clockObj); + if (status != TCL_OK) { goto error2; } } - return slaveInterp; @@ -2189,8 +2179,8 @@ SlaveCreate(interp, pathPtr, safe) * * SlaveObjCmd -- * - * Command to manipulate an interpreter, e.g. to send commands to it - * to be evaluated. One such command exists for each slave interpreter. + * Command to manipulate an interpreter, e.g. to send commands to it to + * be evaluated. One such command exists for each slave interpreter. * * Results: * A standard Tcl result. @@ -2220,15 +2210,15 @@ SlaveObjCmd(clientData, interp, objc, objv) OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT }; - + slaveInterp = (Tcl_Interp *) clientData; if (slaveInterp == NULL) { Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); - return TCL_ERROR; + Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); + return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { @@ -2236,155 +2226,142 @@ SlaveObjCmd(clientData, interp, objc, objv) } switch ((enum options) index) { - case OPT_ALIAS: { - if (objc > 2) { - if (objc == 3) { - return AliasDescribe(interp, slaveInterp, objv[2]); - } - if (Tcl_GetString(objv[3])[0] == '\0') { - if (objc == 4) { - return AliasDelete(interp, slaveInterp, objv[2]); - } - } else { - return AliasCreate(interp, slaveInterp, interp, objv[2], - objv[3], objc - 4, objv + 4); + case OPT_ALIAS: + if (objc > 2) { + if (objc == 3) { + return AliasDescribe(interp, slaveInterp, objv[2]); + } + if (Tcl_GetString(objv[3])[0] == '\0') { + if (objc == 4) { + return AliasDelete(interp, slaveInterp, objv[2]); } + } else { + return AliasCreate(interp, slaveInterp, interp, objv[2], + objv[3], objc - 4, objv + 4); } - Tcl_WrongNumArgs(interp, 2, objv, - "aliasName ?targetName? ?args..?"); - return TCL_ERROR; } - case OPT_ALIASES: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); - return TCL_ERROR; - } - return AliasList(interp, slaveInterp); + Tcl_WrongNumArgs(interp, 2, objv, "aliasName ?targetName? ?args..?"); + return TCL_ERROR; + case OPT_ALIASES: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; } - case OPT_BGERROR: { - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); - return TCL_ERROR; - } - return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + return AliasList(interp, slaveInterp); + case OPT_BGERROR: + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?cmdPrefix?"); + return TCL_ERROR; } - case OPT_EVAL: { - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); - return TCL_ERROR; - } - return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2); + case OPT_EVAL: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?"); + return TCL_ERROR; } - case OPT_EXPOSE: { - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); - return TCL_ERROR; - } - return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + return SlaveEval(interp, slaveInterp, objc - 2, objv + 2); + case OPT_EXPOSE: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?"); + return TCL_ERROR; } - case OPT_HIDE: { - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); - return TCL_ERROR; - } - return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + return SlaveExpose(interp, slaveInterp, objc - 2, objv + 2); + case OPT_HIDE: + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?"); + return TCL_ERROR; } - case OPT_HIDDEN: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return SlaveHidden(interp, slaveInterp); + return SlaveHide(interp, slaveInterp, objc - 2, objv + 2); + case OPT_HIDDEN: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; } - case OPT_ISSAFE: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return SlaveHidden(interp, slaveInterp); + case OPT_ISSAFE: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, (char *) NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); + return TCL_OK; + case OPT_INVOKEHIDDEN: { + int i, index; + CONST char *namespaceName; + static CONST char *hiddenOptions[] = { + "-global", "-namespace", "--", + NULL + }; + enum hiddenOption { + OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST + }; + + namespaceName = NULL; + for (i = 2; i < objc; i++) { + if (Tcl_GetString(objv[i])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", + 0, &index) != TCL_OK) { return TCL_ERROR; } - Tcl_SetObjResult(interp, - Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp))); - return TCL_OK; - } - case OPT_INVOKEHIDDEN: { - int i, index; - CONST char *namespaceName; - static CONST char *hiddenOptions[] = { - "-global", "-namespace", "--", NULL - }; - enum hiddenOption { - OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - }; - - namespaceName = NULL; - for (i = 2; i < objc; i++) { - if (Tcl_GetString(objv[i])[0] != '-') { + if (index == OPT_GLOBAL) { + namespaceName = "::"; + } else if (index == OPT_NAMESPACE) { + if (++i == objc) { /* There must be more arguments. */ break; - } - if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, - "option", 0, &index) != TCL_OK) { - return TCL_ERROR; - } - if (index == OPT_GLOBAL) { - namespaceName = "::"; } else { - if (index == OPT_NAMESPACE) { - if (++i == objc) { /* There must be more arguments. */ - break; - } else { - namespaceName = Tcl_GetString(objv[i]); - } - } else { - i++; - break; - } + namespaceName = Tcl_GetString(objv[i]); } + } else { + i++; + break; } - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 2, objv, - "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); - return TCL_ERROR; - } - return SlaveInvokeHidden(interp, slaveInterp, namespaceName, - objc - i, objv + i); } - case OPT_LIMIT: { - static CONST char *limitTypes[] = { - "commands", "time", NULL - }; - enum LimitTypes { - LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - }; - int limitType; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", - 0, &limitType) != TCL_OK) { - return TCL_ERROR; - } - switch ((enum LimitTypes) limitType) { - case LIMIT_TYPE_COMMANDS: - return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); - case LIMIT_TYPE_TIME: - return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); - } + if (objc - i < 1) { + Tcl_WrongNumArgs(interp, 2, objv, + "?-namespace ns? ?-global? ?--? cmd ?arg ..?"); + return TCL_ERROR; } - case OPT_MARKTRUSTED: { - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - return TCL_ERROR; - } - return SlaveMarkTrusted(interp, slaveInterp); + return SlaveInvokeHidden(interp, slaveInterp, namespaceName, + objc - i, objv + i); + } + case OPT_LIMIT: { + static CONST char *limitTypes[] = { + "commands", "time", NULL + }; + enum LimitTypes { + LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME + }; + int limitType; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "limitType ?options?"); + return TCL_ERROR; } - case OPT_RECLIMIT: { - if (objc != 2 && objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); - return TCL_ERROR; - } - return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); + if (Tcl_GetIndexFromObj(interp, objv[2], limitTypes, "limit type", 0, + &limitType) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LimitTypes) limitType) { + case LIMIT_TYPE_COMMANDS: + return SlaveCommandLimitCmd(interp, slaveInterp, 3, objc,objv); + case LIMIT_TYPE_TIME: + return SlaveTimeLimitCmd(interp, slaveInterp, 3, objc, objv); + } + } + case OPT_MARKTRUSTED: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + return TCL_ERROR; + } + return SlaveMarkTrusted(interp, slaveInterp); + case OPT_RECLIMIT: + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "?newlimit?"); + return TCL_ERROR; } + return SlaveRecursionLimit(interp, slaveInterp, objc - 2, objv + 2); } return TCL_ERROR; @@ -2403,8 +2380,8 @@ SlaveObjCmd(clientData, interp, objc, objv) * None. * * Side effects: - * Cleans up all state associated with the slave interpreter and - * destroys the slave interpreter. + * Cleans up all state associated with the slave interpreter and destroys + * the slave interpreter. * *---------------------------------------------------------------------- */ @@ -2426,9 +2403,9 @@ SlaveObjCmdDeleteProc(clientData) Tcl_DeleteHashEntry(slavePtr->slaveEntryPtr); /* - * Set to NULL so that when the InterpInfo is cleaned up in the slave - * it does not try to delete the command causing all sorts of grief. - * See SlaveRecordDeleteProc(). + * Set to NULL so that when the InterpInfo is cleaned up in the slave it + * does not try to delete the command causing all sorts of grief. See + * SlaveRecordDeleteProc(). */ slavePtr->interpCmd = NULL; @@ -2464,7 +2441,7 @@ SlaveEval(interp, slaveInterp, objc, objv) { int result; Tcl_Obj *objPtr; - + Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); @@ -2493,8 +2470,8 @@ SlaveEval(interp, slaveInterp, objc, objv) * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will be able to invoke - * the newly exposed command. + * After this call scripts in the slave will be able to invoke the newly + * exposed command. * *---------------------------------------------------------------------- */ @@ -2507,7 +2484,7 @@ SlaveExpose(interp, slaveInterp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot expose commands", @@ -2535,8 +2512,8 @@ SlaveExpose(interp, slaveInterp, objc, objv) * A standard Tcl result. * * Side effects: - * When (objc == 1), slaveInterp will be set to a new recursion - * limit of objv[0]. + * When (objc == 1), slaveInterp will be set to a new recursion limit of + * objv[0]. * *---------------------------------------------------------------------- */ @@ -2574,11 +2551,11 @@ SlaveRecursionLimit(interp, slaveInterp, objc, objv) return TCL_ERROR; } Tcl_SetObjResult(interp, objv[0]); - return TCL_OK; + return TCL_OK; } else { limit = Tcl_SetRecursionLimit(slaveInterp, 0); Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); - return TCL_OK; + return TCL_OK; } } @@ -2593,8 +2570,8 @@ SlaveRecursionLimit(interp, slaveInterp, objc, objv) * A standard Tcl result. * * Side effects: - * After this call scripts in the slave will no longer be able - * to invoke the named command. + * After this call scripts in the slave will no longer be able to invoke + * the named command. * *---------------------------------------------------------------------- */ @@ -2607,7 +2584,7 @@ SlaveHide(interp, slaveInterp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument strings. */ { char *name; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "permission denied: safe interpreter cannot hide commands", @@ -2616,8 +2593,7 @@ SlaveHide(interp, slaveInterp, objc, objv) } name = Tcl_GetString(objv[(objc == 1) ? 0 : 1]); - if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), - name) != TCL_OK) { + if (Tcl_HideCommand(slaveInterp, Tcl_GetString(objv[0]), name) != TCL_OK) { TclTransferResult(slaveInterp, TCL_ERROR, interp); return TCL_ERROR; } @@ -2650,13 +2626,12 @@ SlaveHidden(interp, slaveInterp) Tcl_HashTable *hTblPtr; /* For local searches. */ Tcl_HashEntry *hPtr; /* For local searches. */ Tcl_HashSearch hSearch; /* For local searches. */ - + hTblPtr = ((Interp *) slaveInterp)->hiddenCmdTablePtr; if (hTblPtr != (Tcl_HashTable *) NULL) { for (hPtr = Tcl_FirstHashEntry(hTblPtr, &hSearch); - hPtr != (Tcl_HashEntry *) NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - + hPtr != (Tcl_HashEntry *) NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { Tcl_ListObjAppendElement(NULL, listObjPtr, Tcl_NewStringObj(Tcl_GetHashKey(hTblPtr, hPtr), -1)); } @@ -2684,14 +2659,14 @@ SlaveHidden(interp, slaveInterp) static int SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter in which command - * will be invoked. */ + Tcl_Interp *slaveInterp; /* The slave interpreter in which command will + * be invoked. */ CONST char *namespaceName; /* The namespace to use, if any. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ { int result; - + if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "not allowed to invoke hidden commands from safe interpreter", @@ -2701,15 +2676,15 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) Tcl_Preserve((ClientData) slaveInterp); Tcl_AllowExceptions(slaveInterp); - + if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); } else { Namespace *nsPtr, *dummy1, *dummy2; CONST char *tail; result = TclGetNamespaceForQualName(slaveInterp, namespaceName, - (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY + (Namespace *) NULL, TCL_FIND_ONLY_NS | TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG | TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy1, &dummy2, &tail); if (result == TCL_OK) { @@ -2721,7 +2696,7 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) TclTransferResult(slaveInterp, result, interp); Tcl_Release((ClientData) slaveInterp); - return result; + return result; } /* @@ -2735,8 +2710,8 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) * A standard Tcl result. * * Side effects: - * After this call the hard-wired security checks in the core no - * longer prevent the slave from performing certain operations. + * After this call the hard-wired security checks in the core no longer + * prevent the slave from performing certain operations. * *---------------------------------------------------------------------- */ @@ -2744,8 +2719,8 @@ SlaveInvokeHidden(interp, slaveInterp, namespaceName, objc, objv) static int SlaveMarkTrusted(interp, slaveInterp) Tcl_Interp *interp; /* Interp for error return. */ - Tcl_Interp *slaveInterp; /* The slave interpreter which will be - * marked trusted. */ + Tcl_Interp *slaveInterp; /* The slave interpreter which will be marked + * trusted. */ { if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2780,7 +2755,7 @@ Tcl_IsSafe(interp) Interp *iPtr; if (interp == (Tcl_Interp *) NULL) { - return 0; + return 0; } iPtr = (Interp *) interp; @@ -2793,15 +2768,15 @@ Tcl_IsSafe(interp) * Tcl_MakeSafe -- * * Makes its argument interpreter contain only functionality that is - * defined to be part of Safe Tcl. Unsafe commands are hidden, the - * env array is unset, and the standard channels are removed. + * defined to be part of Safe Tcl. Unsafe commands are hidden, the env + * array is unset, and the standard channels are removed. * * Results: * None. * * Side effects: - * Hides commands in its argument interpreter, and removes settings - * and channels. + * Hides commands in its argument interpreter, and removes settings and + * channels. * *---------------------------------------------------------------------- */ @@ -2810,17 +2785,16 @@ int Tcl_MakeSafe(interp) Tcl_Interp *interp; /* Interpreter to be made safe. */ { - Tcl_Channel chan; /* Channel to remove from - * safe interpreter. */ + Tcl_Channel chan; /* Channel to remove from safe interpreter. */ Interp *iPtr = (Interp *) interp; TclHideUnsafeCommands(interp); - + iPtr->flags |= SAFE_INTERP; /* - * Unsetting variables : (which should not have been set - * in the first place, but...) + * Unsetting variables : (which should not have been set in the first + * place, but...) */ /* @@ -2829,7 +2803,7 @@ Tcl_MakeSafe(interp) Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY); - /* + /* * Remove unsafe parts of tcl_platform */ @@ -2839,36 +2813,35 @@ Tcl_MakeSafe(interp) Tcl_UnsetVar2(interp, "tcl_platform", "user", TCL_GLOBAL_ONLY); /* - * Unset path informations variables - * (the only one remaining is [info nameofexecutable]) + * Unset path informations variables (the only one remaining is [info + * nameofexecutable]) */ Tcl_UnsetVar(interp, "tclDefaultLibrary", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY); - + /* - * Remove the standard channels from the interpreter; safe interpreters - * do not ordinarily have access to stdin, stdout and stderr. + * Remove the standard channels from the interpreter; safe interpreters do + * not ordinarily have access to stdin, stdout and stderr. * * NOTE: These channels are not added to the interpreter by the * Tcl_CreateInterp call, but may be added later, by another I/O - * operation. We want to ensure that the interpreter does not have - * these channels even if it is being made safe after being used for - * some time.. + * operation. We want to ensure that the interpreter does not have these + * channels even if it is being made safe after being used for some time.. */ chan = Tcl_GetStdChannel(TCL_STDIN); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != (Tcl_Channel) NULL) { - Tcl_UnregisterChannel(interp, chan); + Tcl_UnregisterChannel(interp, chan); } return TCL_OK; @@ -2879,9 +2852,9 @@ Tcl_MakeSafe(interp) * * Tcl_LimitExceeded -- * - * Tests whether any limit has been exceeded in the given - * interpreter (i.e. whether the interpreter is currently unable - * to process further scripts). + * Tests whether any limit has been exceeded in the given interpreter + * (i.e. whether the interpreter is currently unable to process further + * scripts). * * Results: * A boolean value. @@ -2906,9 +2879,9 @@ Tcl_LimitExceeded(interp) * * Tcl_LimitReady -- * - * Find out whether any limit has been set on the interpreter, - * and if so check whether the granularity of that limit is such - * that the full limit check should be carried out. + * Find out whether any limit has been set on the interpreter, and if so + * check whether the granularity of that limit is such that the full + * limit check should be carried out. * * Results: * A boolean value that indicates whether to call Tcl_LimitCheck. @@ -2930,12 +2903,12 @@ Tcl_LimitReady(interp) if ((iPtr->limit.active & TCL_LIMIT_COMMANDS) && ((iPtr->limit.cmdGranularity == 1) || - (ticker % iPtr->limit.cmdGranularity == 0))) { + (ticker % iPtr->limit.cmdGranularity == 0))) { return 1; } if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || - (ticker % iPtr->limit.timeGranularity == 0))) { + (ticker % iPtr->limit.timeGranularity == 0))) { return 1; } } @@ -2947,20 +2920,20 @@ Tcl_LimitReady(interp) * * Tcl_LimitCheck -- * - * Check all currently set limits in the interpreter (where - * permitted by granularity). If a limit is exceeded, call its - * callbacks and, if the limit is still exceeded after the - * callbacks have run, make the interpreter generate an error - * that cannot be caught within the limited interpreter. + * Check all currently set limits in the interpreter (where permitted by + * granularity). If a limit is exceeded, call its callbacks and, if the + * limit is still exceeded after the callbacks have run, make the + * interpreter generate an error that cannot be caught within the limited + * interpreter. * * Results: - * A Tcl result value (TCL_OK if no limit is exceeded, and - * TCL_ERROR if a limit has been exceeded). + * A Tcl result value (TCL_OK if no limit is exceeded, and TCL_ERROR if a + * limit has been exceeded). * * Side effects: - * May invoke system calls. May invoke other interpreters. May - * be reentrant. May put the interpreter into a state where it - * can no longer execute commands without outside intervention. + * May invoke system calls. May invoke other interpreters. May be + * reentrant. May put the interpreter into a state where it can no longer + * execute commands without outside intervention. * *---------------------------------------------------------------------- */ @@ -2996,7 +2969,7 @@ Tcl_LimitCheck(interp) if ((iPtr->limit.active & TCL_LIMIT_TIME) && ((iPtr->limit.timeGranularity == 1) || - (ticker % iPtr->limit.timeGranularity == 0))) { + (ticker % iPtr->limit.timeGranularity == 0))) { Tcl_Time now; Tcl_GetTime(&now); @@ -3028,9 +3001,9 @@ Tcl_LimitCheck(interp) * * RunLimitHandlers -- * - * Invoke all the limit handlers in a list (for a particular - * limit). Note that no particular limit handler callback will - * be invoked reentrantly. + * Invoke all the limit handlers in a list (for a particular limit). + * Note that no particular limit handler callback will be invoked + * reentrantly. * * Results: * None. @@ -3050,17 +3023,18 @@ RunLimitHandlers(handlerPtr, interp) for (; handlerPtr!=NULL ; handlerPtr=nextPtr) { if (handlerPtr->flags & (LIMIT_HANDLER_DELETED|LIMIT_HANDLER_ACTIVE)) { /* - * Reentrant call or something seriously strange in the - * delete code. + * Reentrant call or something seriously strange in the delete + * code. */ + nextPtr = handlerPtr->nextPtr; continue; } /* - * Set the ACTIVE flag while running the limit handler itself - * so we cannot reentrantly call this handler and know to use - * the alternate method of deletion if necessary. + * Set the ACTIVE flag while running the limit handler itself so we + * cannot reentrantly call this handler and know to use the alternate + * method of deletion if necessary. */ handlerPtr->flags |= LIMIT_HANDLER_ACTIVE; @@ -3068,20 +3042,21 @@ RunLimitHandlers(handlerPtr, interp) handlerPtr->flags &= ~LIMIT_HANDLER_ACTIVE; /* - * Rediscover this value; it might have changed during the - * processing of a limit handler. We have to record it here - * because we might delete the structure below, and reading a - * value out of a deleted structure is unsafe (even if - * actually legal with some malloc()/free() implementations.) + * Rediscover this value; it might have changed during the processing + * of a limit handler. We have to record it here because we might + * delete the structure below, and reading a value out of a deleted + * structure is unsafe (even if actually legal with some + * malloc()/free() implementations.) */ nextPtr = handlerPtr->nextPtr; /* - * If we deleted the current handler while we were executing - * it, we will have spliced it out of the list and set the + * If we deleted the current handler while we were executing it, we + * will have spliced it out of the list and set the * LIMIT_HANDLER_DELETED flag. */ + if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { if (handlerPtr->deleteProc != NULL) { (handlerPtr->deleteProc)(handlerPtr->clientData); @@ -3176,10 +3151,10 @@ Tcl_LimitAddHandler(interp, type, handlerProc, clientData, deleteProc) * None. * * Side effects: - * The handler is spliced out of the internal linked list for the - * limit, and if not currently being invoked, deleted. Otherwise - * it is just marked for deletion and removed when the limit - * handler has finished executing. + * The handler is spliced out of the internal linked list for the limit, + * and if not currently being invoked, deleted. Otherwise it is just + * marked for deletion and removed when the limit handler has finished + * executing. * *---------------------------------------------------------------------- */ @@ -3213,8 +3188,8 @@ Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) } /* - * We've found the handler to delete; mark it as doomed if not - * already so marked (which shouldn't actually happen). + * We've found the handler to delete; mark it as doomed if not already + * so marked (which shouldn't actually happen). */ if (handlerPtr->flags & LIMIT_HANDLER_DELETED) { @@ -3243,9 +3218,9 @@ Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) } /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { @@ -3263,8 +3238,8 @@ Tcl_LimitRemoveHandler(interp, type, handlerProc, clientData) * * TclLimitRemoveAllHandlers -- * - * Remove all limit callback handlers for an interpreter. This - * is invoked as part of deleting the interpreter. + * Remove all limit callback handlers for an interpreter. This is invoked + * as part of deleting the interpreter. * * Results: * None. @@ -3303,9 +3278,9 @@ TclLimitRemoveAllHandlers(interp) handlerPtr->nextPtr = NULL; /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { @@ -3336,9 +3311,9 @@ TclLimitRemoveAllHandlers(interp) handlerPtr->nextPtr = NULL; /* - * If nothing is currently executing the handler, delete its - * client data and the overall handler structure now. - * Otherwise it will all go away when the handler returns. + * If nothing is currently executing the handler, delete its client + * data and the overall handler structure now. Otherwise it will all + * go away when the handler returns. */ if (!(handlerPtr->flags & LIMIT_HANDLER_ACTIVE)) { @@ -3350,8 +3325,8 @@ TclLimitRemoveAllHandlers(interp) } /* - * Delete the timer callback that is used to trap limits that - * occur in [vwait]s... + * Delete the timer callback that is used to trap limits that occur in + * [vwait]s... */ if (iPtr->limit.timeEvent != NULL) { @@ -3365,8 +3340,7 @@ TclLimitRemoveAllHandlers(interp) * * Tcl_LimitTypeEnabled -- * - * Check whether a particular limit has been enabled for an - * interpreter. + * Check whether a particular limit has been enabled for an interpreter. * * Results: * A boolean value. @@ -3392,12 +3366,11 @@ Tcl_LimitTypeEnabled(interp, type) * * Tcl_LimitTypeExceeded -- * - * Check whether a particular limit has been exceeded for an - * interpreter. + * Check whether a particular limit has been exceeded for an interpreter. * * Results: - * A boolean value (note that Tcl_LimitExceeded will always - * return non-zero when this function returns non-zero). + * A boolean value (note that Tcl_LimitExceeded will always return + * non-zero when this function returns non-zero). * * Side effects: * None. @@ -3426,9 +3399,9 @@ Tcl_LimitTypeExceeded(interp, type) * None. * * Side effects: - * The limit is turned on and will be checked in future at an - * interval determined by the frequency of calling of - * Tcl_LimitReady and the granularity of the limit in question. + * The limit is turned on and will be checked in future at an interval + * determined by the frequency of calling of Tcl_LimitReady and the + * granularity of the limit in question. * *---------------------------------------------------------------------- */ @@ -3454,10 +3427,10 @@ Tcl_LimitTypeSet(interp, type) * None. * * Side effects: - * The limit is disabled. If the limit was exceeded when this - * function was called, the limit will no longer be exceeded - * afterwards and the interpreter will be free to execute further - * scripts (assuming it isn't also deleted, of course). + * The limit is disabled. If the limit was exceeded when this function + * was called, the limit will no longer be exceeded afterwards and the + * interpreter will be free to execute further scripts (assuming it isn't + * also deleted, of course). * *---------------------------------------------------------------------- */ @@ -3484,10 +3457,9 @@ Tcl_LimitTypeReset(interp, type) * None. * * Side effects: - * Also resets whether the command limit was exceeded. This - * might permit a small amount of further execution in the - * interpreter even if the limit itself is theoretically - * exceeded. + * Also resets whether the command limit was exceeded. This might permit + * a small amount of further execution in the interpreter even if the + * limit itself is theoretically exceeded. * *---------------------------------------------------------------------- */ @@ -3508,8 +3480,8 @@ Tcl_LimitSetCommands(interp, commandLimit) * * Tcl_LimitGetCommands -- * - * Get the number of commands that may be executed in the - * interpreter before the command-limit is reached. + * Get the number of commands that may be executed in the interpreter + * before the command-limit is reached. * * Results: * An upper bound on the number of commands. @@ -3534,16 +3506,16 @@ Tcl_LimitGetCommands(interp) * * Tcl_LimitSetTime -- * - * Set the time limit for an interpreter by copying it from the - * value pointed to by the timeLimitPtr argument. + * Set the time limit for an interpreter by copying it from the value + * pointed to by the timeLimitPtr argument. * * Results: * None. * * Side effects: - * Also resets whether the time limit was exceeded. This might - * permit a small amount of further execution in the interpreter - * even if the limit itself is theoretically exceeded. + * Also resets whether the time limit was exceeded. This might permit a + * small amount of further execution in the interpreter even if the limit + * itself is theoretically exceeded. * *---------------------------------------------------------------------- */ @@ -3576,15 +3548,15 @@ Tcl_LimitSetTime(interp, timeLimitPtr) * * TimeLimitCallback -- * - * Callback that allows time limits to be enforced even when - * doing a blocking wait for events. + * Callback that allows time limits to be enforced even when doing a + * blocking wait for events. * * Results: * None. * * Side effects: - * May put the interpreter into a state where it can no longer - * execute commands. May make callbacks into other interpreters. + * May put the interpreter into a state where it can no longer execute + * commands. May make callbacks into other interpreters. * *---------------------------------------------------------------------- */ @@ -3612,8 +3584,8 @@ TimeLimitCallback(clientData) * Get the current time limit. * * Results: - * The time limit (by it being copied into the variable pointed - * to by the timeLimitPtr). + * The time limit (by it being copied into the variable pointed to by the + * timeLimitPtr). * * Side effects: * None. @@ -3636,8 +3608,8 @@ Tcl_LimitGetTime(interp, timeLimitPtr) * * Tcl_LimitSetGranularity -- * - * Set the granularity divisor (which must be positive) for a - * particular limit. + * Set the granularity divisor (which must be positive) for a particular + * limit. * * Results: * None. @@ -3701,23 +3673,22 @@ Tcl_LimitGetGranularity(interp, type) } Tcl_Panic("unknown type of resource limit"); return -1; /* NOT REACHED */ -} +} /* *---------------------------------------------------------------------- * * DeleteScriptLimitCallback -- * - * Callback for when a script limit (a limit callback implemented - * as a Tcl script in a master interpreter, as set up from Tcl) - * is deleted. + * Callback for when a script limit (a limit callback implemented as a + * Tcl script in a master interpreter, as set up from Tcl) is deleted. * * Results: * None. * * Side effects: - * The reference to the script callback from the controlling - * interpreter is removed. + * The reference to the script callback from the controlling interpreter + * is removed. * *---------------------------------------------------------------------- */ @@ -3739,15 +3710,15 @@ DeleteScriptLimitCallback(clientData) * * CallScriptLimitCallback -- * - * Invoke a script limit callback. Used to implement limit - * callbacks set at the Tcl level on child interpreters. + * Invoke a script limit callback. Used to implement limit callbacks set + * at the Tcl level on child interpreters. * * Results: * None. * * Side effects: - * Depends on the callback script. Errors are reported as - * background errors. + * Depends on the callback script. Errors are reported as background + * errors. * *---------------------------------------------------------------------- */ @@ -3778,19 +3749,18 @@ CallScriptLimitCallback(clientData, interp) * * SetScriptLimitCallback -- * - * Install (or remove, if scriptObj is NULL) a limit callback - * script that is called when the target interpreter exceeds the - * type of limit specified. Each interpreter may only have one - * callback set on another interpreter through this mechanism - * (though as many interpreters may be limited as the programmer - * chooses overall). + * Install (or remove, if scriptObj is NULL) a limit callback script that + * is called when the target interpreter exceeds the type of limit + * specified. Each interpreter may only have one callback set on another + * interpreter through this mechanism (though as many interpreters may be + * limited as the programmer chooses overall). * * Results: * None. * * Side effects: - * A limit callback implemented as an invokation of a Tcl script - * in another interpreter is either installed or removed. + * A limit callback implemented as an invokation of a Tcl script in + * another interpreter is either installed or removed. * *---------------------------------------------------------------------- */ @@ -3849,16 +3819,15 @@ SetScriptLimitCallback(interp, type, targetInterp, scriptObj) * * TclRemoveScriptLimitCallbacks -- * - * Remove all script-implemented limit callbacks that make calls - * back into the given interpreter. This invoked as part of - * deleting an interpreter. + * Remove all script-implemented limit callbacks that make calls back + * into the given interpreter. This invoked as part of deleting an + * interpreter. * * Results: * None. * * Side effects: - * The script limit callbacks are removed or marked for later - * removal. + * The script limit callbacks are removed or marked for later removal. * *---------------------------------------------------------------------- */ @@ -3888,10 +3857,9 @@ TclRemoveScriptLimitCallbacks(interp) * * TclInitLimitSupport -- * - * Initialise all the parts of the interpreter relating to - * resource limit management. This allows an interpreter to both - * have limits set upon itself and set limits upon other - * interpreters. + * Initialise all the parts of the interpreter relating to resource limit + * management. This allows an interpreter to both have limits set upon + * itself and set limits upon other interpreters. * * Results: * None. @@ -3927,17 +3895,17 @@ TclInitLimitSupport(interp) * * InheritLimitsFromMaster -- * - * Derive the interpreter limit configuration for a slave - * interpreter from the limit config for the master. + * Derive the interpreter limit configuration for a slave interpreter + * from the limit config for the master. * * Results: * None. * * Side effects: - * The slave interpreter limits are set so that if the master has - * a limit, it may not exceed it by handing off work to slave - * interpreters. Note that this does not transfer limit - * callbacks from the master to the slave. + * The slave interpreter limits are set so that if the master has a + * limit, it may not exceed it by handing off work to slave interpreters. + * Note that this does not transfer limit callbacks from the master to + * the slave. * *---------------------------------------------------------------------- */ @@ -4018,6 +3986,7 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) } } else { Tcl_Obj *empty; + putEmptyCommandInDict: TclNewObj(empty); Tcl_DictObjPut(NULL, dictPtr, @@ -4140,9 +4109,8 @@ SlaveCommandLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) * * SlaveTimeLimitCmd -- * - * Implementation of the [interp limit $i time] and [$i limit - * time] subcommands. See the interp manual page for a full - * description. + * Implementation of the [interp limit $i time] and [$i limit time] + * subcommands. See the interp manual page for a full description. * * Results: * A standard Tcl result. @@ -4331,10 +4299,10 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (milliObj != NULL || secObj != NULL) { if (milliObj != NULL) { /* - * Setting -milliseconds but clearing -seconds, or - * resetting -milliseconds but not resetting -seconds? - * Bad voodoo! + * Setting -milliseconds but clearing -seconds, or resetting + * -milliseconds but not resetting -seconds? Bad voodoo! */ + if (secObj != NULL && secLen == 0 && milliLen > 0) { Tcl_AppendResult(interp, "may only set -milliseconds ", "if -seconds is not also being reset", NULL); @@ -4350,10 +4318,10 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) if (milliLen > 0 || secLen > 0) { /* * Force usec to be in range [0..1000000), possibly - * incrementing sec in the process. This makes it - * much easier for people to write scripts that do - * small time increments. + * incrementing sec in the process. This makes it much easier + * for people to write scripts that do small time increments. */ + limitMoment.sec += limitMoment.usec / 1000000; limitMoment.usec %= 1000000; @@ -4373,3 +4341,11 @@ SlaveTimeLimitCmd(interp, slaveInterp, consumedObjc, objc, objv) return TCL_OK; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclLink.c b/generic/tclLink.c index eb6fa76..d04db83 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -1,55 +1,53 @@ /* * tclLink.c -- * - * This file implements linked variables (a C variable that is - * tied to a Tcl variable). The idea of linked variables was - * first suggested by Andreas Stolcke and this implementation is - * based heavily on a prototype implementation provided by - * him. + * This file implements linked variables (a C variable that is tied to a + * Tcl variable). The idea of linked variables was first suggested by + * Andreas Stolcke and this implementation is based heavily on a + * prototype implementation provided by him. * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLink.c,v 1.9 2005/07/06 15:18:01 dgp Exp $ + * RCS: @(#) $Id: tclLink.c,v 1.10 2005/07/17 21:17:43 dkf Exp $ */ #include "tclInt.h" /* - * For each linked variable there is a data structure of the following - * type, which describes the link and is the clientData for the trace - * set on the Tcl variable. + * For each linked variable there is a data structure of the following type, + * which describes the link and is the clientData for the trace set on the Tcl + * variable. */ typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ - Tcl_Obj *varName; /* Name of variable (must be global). This - * is needed during trace callbacks, since - * the actual variable may be aliased at - * that time via upvar. */ + Tcl_Obj *varName; /* Name of variable (must be global). This is + * needed during trace callbacks, since the + * actual variable may be aliased at that time + * via upvar. */ char *addr; /* Location of C variable. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { int i; double d; Tcl_WideInt w; - } lastValue; /* Last known value of C variable; used to + } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ - int flags; /* Miscellaneous one-bit values; see below - * for definitions. */ + int flags; /* Miscellaneous one-bit values; see below for + * definitions. */ } Link; /* * Definitions for flag bits: * LINK_READ_ONLY - 1 means errors should be generated if Tcl * script attempts to write variable. - * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar - * is in progress for this variable, so - * trace callbacks on the variable should - * be ignored. + * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is + * in progress for this variable, so trace + * callbacks on the variable should be ignored. */ #define LINK_READ_ONLY 1 @@ -69,18 +67,17 @@ static Tcl_Obj * ObjValue _ANSI_ARGS_((Link *linkPtr)); * * Tcl_LinkVar -- * - * Link a C variable to a Tcl variable so that changes to either - * one causes the other to change. + * Link a C variable to a Tcl variable so that changes to either one + * causes the other to change. * * Results: - * The return value is TCL_OK if everything went well or TCL_ERROR - * if an error occurred (the interp's result is also set after - * errors). + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). * * Side effects: - * The value at *addr is linked to the Tcl variable "varName", - * using "type" to convert between string values for Tcl and - * binary values for *addr. + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. * *---------------------------------------------------------------------- */ @@ -89,11 +86,11 @@ int Tcl_LinkVar(interp, varName, addr, type) Tcl_Interp *interp; /* Interpreter in which varName exists. */ CONST char *varName; /* Name of a global variable in interp. */ - char *addr; /* Address of a C variable to be linked - * to varName. */ - int type; /* Type of C variable: TCL_LINK_INT, etc. - * Also may have TCL_LINK_READ_ONLY - * OR'ed in. */ + char *addr; /* Address of a C variable to be linked to + * varName. */ + int type; /* Type of C variable: TCL_LINK_INT, etc. + * Also may have TCL_LINK_READ_ONLY OR'ed + * in. */ { Tcl_Obj *objPtr; Link *linkPtr; @@ -139,16 +136,16 @@ Tcl_LinkVar(interp, varName, addr, type) * None. * * Side effects: - * If "varName" was previously linked to a C variable, the link - * is broken to make the variable independent. If there was no - * previous link for "varName" then nothing happens. + * If "varName" was previously linked to a C variable, the link is broken + * to make the variable independent. If there was no previous link for + * "varName" then nothing happens. * *---------------------------------------------------------------------- */ void Tcl_UnlinkVar(interp, varName) - Tcl_Interp *interp; /* Interpreter containing variable to unlink. */ + Tcl_Interp *interp; /* Interpreter containing variable to unlink */ CONST char *varName; /* Global variable in interp to unlink. */ { Link *linkPtr; @@ -170,16 +167,16 @@ Tcl_UnlinkVar(interp, varName) * * Tcl_UpdateLinkedVar -- * - * This procedure is invoked after a linked variable has been - * changed by C code. It updates the Tcl variable so that - * traces on the variable will trigger. + * This procedure is invoked after a linked variable has been changed by + * C code. It updates the Tcl variable so that traces on the variable + * will trigger. * * Results: * None. * * Side effects: - * The Tcl variable "varName" is updated from its C value, - * causing traces on the variable to trigger. + * The Tcl variable "varName" is updated from its C value, causing traces + * on the variable to trigger. * *---------------------------------------------------------------------- */ @@ -209,18 +206,18 @@ Tcl_UpdateLinkedVar(interp, varName) * * LinkTraceProc -- * - * This procedure is invoked when a linked Tcl variable is read, - * written, or unset from Tcl. It's responsible for keeping the - * C variable in sync with the Tcl variable. + * This procedure is invoked when a linked Tcl variable is read, written, + * or unset from Tcl. It's responsible for keeping the C variable in sync + * with the Tcl variable. * * Results: - * If all goes well, NULL is returned; otherwise an error message - * is returned. + * If all goes well, NULL is returned; otherwise an error message is + * returned. * * Side effects: - * The C variable may be updated to make it consistent with the - * Tcl variable, or the Tcl variable may be overwritten to reject - * a modification. + * The C variable may be updated to make it consistent with the Tcl + * variable, or the Tcl variable may be overwritten to reject a + * modification. * *---------------------------------------------------------------------- */ @@ -240,8 +237,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) Tcl_Obj *valueObj; /* - * If the variable is being unset, then just re-create it (with a - * trace) unless the whole interpreter is going away. + * If the variable is being unset, then just re-create it (with a trace) + * unless the whole interpreter is going away. */ if (flags & TCL_TRACE_UNSETS) { @@ -259,10 +256,9 @@ LinkTraceProc(clientData, interp, name1, name2, flags) } /* - * If we were invoked because of a call to Tcl_UpdateLinkedVar, then - * don't do anything at all. In particular, we don't want to get - * upset that the variable is being modified, even if it is - * supposed to be read-only. + * If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't + * do anything at all. In particular, we don't want to get upset that the + * variable is being modified, even if it is supposed to be read-only. */ if (linkPtr->flags & LINK_BEING_UPDATED) { @@ -270,8 +266,8 @@ LinkTraceProc(clientData, interp, name1, name2, flags) } /* - * For read accesses, update the Tcl variable if the C variable - * has changed since the last time we updated the Tcl variable. + * For read accesses, update the Tcl variable if the C variable has + * changed since the last time we updated the Tcl variable. */ if (flags & TCL_TRACE_READS) { @@ -301,11 +297,11 @@ LinkTraceProc(clientData, interp, name1, name2, flags) /* * For writes, first make sure that the variable is writable. Then - * convert the Tcl value to C if possible. If the variable isn't - * writable or can't be converted, then restore the varaible's old - * value and return an error. Another tricky thing: we have to save - * and restore the interpreter's result, since the variable access - * could occur when the result has been partially set. + * convert the Tcl value to C if possible. If the variable isn't writable + * or can't be converted, then restore the varaible's old value and return + * an error. Another tricky thing: we have to save and restore the + * interpreter's result, since the variable access could occur when the + * result has been partially set. */ if (linkPtr->flags & LINK_READ_ONLY) { @@ -384,12 +380,12 @@ LinkTraceProc(clientData, interp, name1, name2, flags) * * ObjValue -- * - * Converts the value of a C variable to a Tcl_Obj* for use in a - * Tcl variable to which it is linked. + * Converts the value of a C variable to a Tcl_Obj* for use in a Tcl + * variable to which it is linked. * * Results: - * The return value is a pointer to a Tcl_Obj that represents - * the value of the C variable given by linkPtr. + * The return value is a pointer to a Tcl_Obj that represents the value + * of the C variable given by linkPtr. * * Side effects: * None. @@ -424,10 +420,18 @@ ObjValue(linkPtr) return Tcl_NewStringObj(p, -1); /* - * This code only gets executed if the link type is unknown - * (shouldn't ever happen). + * This code only gets executed if the link type is unknown (shouldn't + * ever happen). */ default: return Tcl_NewStringObj("??", 2); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclLoad.c b/generic/tclLoad.c index 3ce5200..72c33d4 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -1,36 +1,35 @@ -/* +/* * tclLoad.c -- * - * This file provides the generic portion (those that are the same - * on all platforms) of Tcl's dynamic loading facilities. + * This file provides the generic portion (those that are the same on all + * platforms) of Tcl's dynamic loading facilities. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclLoad.c,v 1.13 2004/03/09 12:59:05 vincentdarley Exp $ + * RCS: @(#) $Id: tclLoad.c,v 1.14 2005/07/17 21:17:43 dkf Exp $ */ #include "tclInt.h" /* - * The following structure describes a package that has been loaded - * either dynamically (with the "load" command) or statically (as - * indicated by a call to TclGetLoadedPackages). All such packages - * are linked together into a single list for the process. Packages - * are never unloaded, until the application exits, when - * TclFinalizeLoad is called, and these structures are freed. + * The following structure describes a package that has been loaded either + * dynamically (with the "load" command) or statically (as indicated by a call + * to TclGetLoadedPackages). All such packages are linked together into a + * single list for the process. Packages are never unloaded, until the + * application exits, when TclFinalizeLoad is called, and these structures are + * freed. */ typedef struct LoadedPackage { - char *fileName; /* Name of the file from which the - * package was loaded. An empty string - * means the package is loaded statically. - * Malloc-ed. */ + char *fileName; /* Name of the file from which the package was + * loaded. An empty string means the package + * is loaded statically. Malloc-ed. */ char *packageName; /* Name of package prefix for the package, * properly capitalized (first letter UC, - * others LC), no "_", as in "Net". + * others LC), no "_", as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -44,21 +43,20 @@ typedef struct LoadedPackage { /* Initialization procedure to call to * incorporate this package into a safe * interpreter (one that will execute - * untrusted scripts). NULL means the - * package can't be used in unsafe - * interpreters. */ + * untrusted scripts). NULL means the package + * can't be used in unsafe interpreters. */ Tcl_PackageUnloadProc *unloadProc; - /* Finalisation procedure to unload a package - * from a trusted interpreter. NULL means - * that the package cannot be unloaded. */ + /* Finalisation procedure to unload a package + * from a trusted interpreter. NULL means that + * the package cannot be unloaded. */ Tcl_PackageUnloadProc *safeUnloadProc; - /* Finalisation procedure to unload a package - * from a safe interpreter. NULL means - * that the package cannot be unloaded. */ - int interpRefCount; /* How many times the package has been loaded - in trusted interpreters. */ - int safeInterpRefCount; /* How many times the package has been loaded - in safe interpreters. */ + /* Finalisation procedure to unload a package + * from a safe interpreter. NULL means that + * the package cannot be unloaded. */ + int interpRefCount; /* How many times the package has been loaded + * in trusted interpreters. */ + int safeInterpRefCount; /* How many times the package has been loaded + * in safe interpreters. */ Tcl_FSUnloadFileProc *unLoadProcPtr; /* Procedure to use to unload this package. * If NULL, then we do not attempt to unload @@ -66,8 +64,8 @@ typedef struct LoadedPackage { * this field is irrelevant. */ struct LoadedPackage *nextPtr; /* Next in list of all packages loaded into - * this application process. NULL means - * end of list. */ + * this application process. NULL means end of + * list. */ } LoadedPackage; /* @@ -83,19 +81,19 @@ static LoadedPackage *firstPackagePtr = NULL; TCL_DECLARE_MUTEX(packageMutex) /* - * The following structure represents a particular package that has - * been incorporated into a particular interpreter (by calling its - * initialization procedure). There is a list of these structures for - * each interpreter, with an AssocData value (key "load") for the - * interpreter that points to the first package (if any). + * The following structure represents a particular package that has been + * incorporated into a particular interpreter (by calling its initialization + * procedure). There is a list of these structures for each interpreter, with + * an AssocData value (key "load") for the interpreter that points to the + * first package (if any). */ typedef struct InterpPackage { LoadedPackage *pkgPtr; /* Points to detailed information about * package. */ struct InterpPackage *nextPtr; - /* Next package in this interpreter, or - * NULL for end of list. */ + /* Next package in this interpreter, or NULL + * for end of list. */ } InterpPackage; /* @@ -110,8 +108,8 @@ static void LoadCleanupProc _ANSI_ARGS_((ClientData clientData, * * Tcl_LoadObjCmd -- * - * This procedure is invoked to process the "load" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "load" Tcl command. See the + * user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -131,11 +129,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) { Tcl_Interp *target; LoadedPackage *pkgPtr, *defaultPtr; - Tcl_DString pkgName, tmp, initName, safeInitName, - unloadName, safeUnloadName; + Tcl_DString pkgName, tmp, initName, safeInitName; + Tcl_DString unloadName, safeUnloadName; Tcl_PackageInitProc *initProc, *safeInitProc, *unloadProc, *safeUnloadProc; InterpPackage *ipFirstPtr, *ipPtr; - int code, namesMatch, filesMatch; + int code, namesMatch, filesMatch, offset; CONST char *symbols[4]; Tcl_PackageInitProc **procPtrs[4]; ClientData clientData; @@ -143,17 +141,16 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unLoadProcPtr = NULL; Tcl_UniChar ch; - int offset; if ((objc < 2) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); + Tcl_WrongNumArgs(interp, 1, objv, "fileName ?packageName? ?interp?"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } fullFileName = Tcl_GetString(objv[1]); - + Tcl_DStringInit(&pkgName); Tcl_DStringInit(&initName); Tcl_DStringInit(&safeInitName); @@ -182,8 +179,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) target = interp; if (objc == 4) { - char *slaveIntName; - slaveIntName = Tcl_GetString(objv[3]); + char *slaveIntName = Tcl_GetString(objv[3]); + target = Tcl_GetSlave(interp, slaveIntName); if (target == NULL) { code = TCL_ERROR; @@ -193,13 +190,14 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if - * it meets any of the following conditions: + * package we want is already loaded. We'll use a loaded package if it + * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there - * is only no statically loaded package with the same name. + * - Its name matches, the file name was specified as empty, and there is + * only no statically loaded package with the same name. */ + Tcl_MutexLock(&packageMutex); defaultPtr = NULL; @@ -231,8 +229,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } if (filesMatch && !namesMatch && (fullFileName[0] != 0)) { /* - * Can't have two different packages loaded from the same - * file. + * Can't have two different packages loaded from the same file. */ Tcl_AppendResult(interp, "file \"", fullFileName, @@ -250,8 +247,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, - * then there's nothing for us to do. + * interpreter. If the package we want is already loaded there, then + * there's nothing for us to do. */ if (pkgPtr != NULL) { @@ -267,8 +264,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) if (pkgPtr == NULL) { /* - * The desired file isn't currently loaded, so load it. It's an - * error if the desired package is a static one. + * The desired file isn't currently loaded, so load it. It's an error + * if the desired package is a static one. */ if (fullFileName[0] == 0) { @@ -286,9 +283,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) Tcl_DStringAppend(&pkgName, packageName, -1); } else { int retc; + /* * Threading note - this call used to be protected by a mutex. */ + retc = TclGuessPackageName(fullFileName, &pkgName); if (!retc) { Tcl_Obj *splitPtr; @@ -297,11 +296,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) char *pkgGuess; /* - * The platform-specific code couldn't figure out the - * module name. Make a guess by taking the last element - * of the file name, stripping off any leading "lib", - * and then using all of the alphabetic and underline - * characters that follow that. + * The platform-specific code couldn't figure out the module + * name. Make a guess by taking the last element of the file + * name, stripping off any leading "lib", and then using all + * of the alphabetic and underline characters that follow + * that. */ splitPtr = Tcl_FSSplitPath(objv[1], &pElements); @@ -337,45 +336,47 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * character is in caps (or title case) but the others are all * lower-case. */ - + Tcl_DStringSetLength(&pkgName, Tcl_UtfToTitle(Tcl_DStringValue(&pkgName))); /* - * Compute the names of the two initialization procedures, - * based on the package name. + * Compute the names of the two initialization procedures, based on + * the package name. */ - + Tcl_DStringAppend(&initName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&initName, "_Init", 5); Tcl_DStringAppend(&safeInitName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeInitName, "_SafeInit", 9); - Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&unloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&unloadName, "_Unload", 7); - Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); + Tcl_DStringAppend(&safeUnloadName, Tcl_DStringValue(&pkgName), -1); Tcl_DStringAppend(&safeUnloadName, "_SafeUnload", 11); /* - * Call platform-specific code to load the package and find the - * two initialization procedures. + * Call platform-specific code to load the package and find the two + * initialization procedures. */ - symbols[0] = Tcl_DStringValue(&initName); - symbols[1] = Tcl_DStringValue(&safeInitName); - symbols[2] = Tcl_DStringValue(&unloadName); - symbols[3] = Tcl_DStringValue(&safeUnloadName); - procPtrs[0] = &initProc; - procPtrs[1] = &safeInitProc; - procPtrs[2] = &unloadProc; - procPtrs[3] = &safeUnloadProc; + symbols[0] = Tcl_DStringValue(&initName); + symbols[1] = Tcl_DStringValue(&safeInitName); + symbols[2] = Tcl_DStringValue(&unloadName); + symbols[3] = Tcl_DStringValue(&safeUnloadName); + procPtrs[0] = &initProc; + procPtrs[1] = &safeInitProc; + procPtrs[2] = &unloadProc; + procPtrs[3] = &safeUnloadProc; + Tcl_MutexLock(&packageMutex); code = TclLoadFile(interp, objv[1], 4, symbols, procPtrs, &loadHandle, &clientData, &unLoadProcPtr); Tcl_MutexUnlock(&packageMutex); - loadHandle = (Tcl_LoadHandle) clientData; + loadHandle = (Tcl_LoadHandle) clientData; if (code != TCL_OK) { goto done; } + if (*procPtrs[0] /* initProc */ == NULL) { Tcl_AppendResult(interp, "couldn't find procedure ", Tcl_DStringValue(&initName), (char *) NULL); @@ -401,10 +402,11 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) pkgPtr->unLoadProcPtr = unLoadProcPtr; pkgPtr->initProc = *procPtrs[0]; pkgPtr->safeInitProc = *procPtrs[1]; - pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; - pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; - pkgPtr->interpRefCount = 0; - pkgPtr->safeInterpRefCount = 0; + pkgPtr->unloadProc = (Tcl_PackageUnloadProc*) *procPtrs[2]; + pkgPtr->safeUnloadProc = (Tcl_PackageUnloadProc*) *procPtrs[3]; + pkgPtr->interpRefCount = 0; + pkgPtr->safeInterpRefCount = 0; + Tcl_MutexLock(&packageMutex); pkgPtr->nextPtr = firstPackagePtr; firstPackagePtr = pkgPtr; @@ -412,9 +414,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } /* - * Invoke the package's initialization procedure (either the - * normal one or the safe one, depending on whether or not the - * interpreter is safe). + * Invoke the package's initialization procedure (either the normal one or + * the safe one, depending on whether or not the interpreter is safe). */ if (Tcl_IsSafe(target)) { @@ -422,9 +423,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) code = (*pkgPtr->safeInitProc)(target); } else { Tcl_AppendResult(interp, - "can't use package in a safe interpreter: ", - "no ", pkgPtr->packageName, "_SafeInit procedure", - (char *) NULL); + "can't use package in a safe interpreter: no ", + pkgPtr->packageName, "_SafeInit procedure", (char *) NULL); code = TCL_ERROR; goto done; } @@ -433,21 +433,23 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) } /* - * Record the fact that the package has been loaded in the - * target interpreter. + * Record the fact that the package has been loaded in the target + * interpreter. */ if (code == TCL_OK) { - /* - * Update the proper reference count. - */ - Tcl_MutexLock(&packageMutex); - if (Tcl_IsSafe(target)) { - ++pkgPtr->safeInterpRefCount; - } else { - ++pkgPtr->interpRefCount; - } - Tcl_MutexUnlock(&packageMutex); + /* + * Update the proper reference count. + */ + + Tcl_MutexLock(&packageMutex); + if (Tcl_IsSafe(target)) { + ++pkgPtr->safeInterpRefCount; + } else { + ++pkgPtr->interpRefCount; + } + Tcl_MutexUnlock(&packageMutex); + /* * Refetch ipFirstPtr: loading the package may have introduced * additional static packages at the head of the linked list! @@ -464,7 +466,7 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) TclTransferResult(target, code, interp); } - done: + done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&initName); Tcl_DStringFree(&safeInitName); @@ -479,8 +481,8 @@ Tcl_LoadObjCmd(dummy, interp, objc, objv) * * Tcl_UnloadObjCmd -- * - * This procedure is invoked to process the "unload" Tcl command. - * See the user documentation for details on what it does. + * This procedure is invoked to process the "unload" Tcl command. See + * the user documentation for details on what it does. * * Results: * A standard Tcl result. @@ -499,22 +501,13 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) Tcl_Obj *CONST objv[]; /* Argument objects. */ { Tcl_Interp *target; /* Which interpreter to unload from. */ - LoadedPackage *pkgPtr; - LoadedPackage *defaultPtr; - Tcl_DString pkgName; - Tcl_DString tmp; + LoadedPackage *pkgPtr, *defaultPtr; + Tcl_DString pkgName, tmp; Tcl_PackageUnloadProc *unloadProc; - InterpPackage *ipFirstPtr; - InterpPackage *ipPtr; - int i; - int index; - int code; - int complain = 1; - int keepLibrary = 0; - int trustedRefCount = -1; - int safeRefCount = -1; - char *fullFileName = ""; - char *packageName; + InterpPackage *ipFirstPtr, *ipPtr; + int i, index, code, complain = 1, keepLibrary = 0; + int trustedRefCount = -1, safeRefCount = -1; + char *fullFileName = "", *packageName; static CONST char *options[] = { "-nocomplain", "-keeplibrary", "--", NULL }; @@ -528,15 +521,15 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) fullFileName = Tcl_GetString(objv[i]); if (fullFileName[0] == '-') { /* - * It looks like the command contains an option so signal - * an error + * It looks like the command contains an option so signal an + * error */ return TCL_ERROR; } else { /* - * This clearly isn't an option; assume it's the - * filename. We must clear the error. + * This clearly isn't an option; assume it's the filename. We + * must clear the error. */ Tcl_ResetResult(interp); @@ -555,7 +548,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) goto endOfForLoop; } } - endOfForLoop: + endOfForLoop: if ((objc-i < 1) || (objc-i > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "?switches? fileName ?packageName? ?interp?"); @@ -564,7 +557,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { return TCL_ERROR; } - + fullFileName = Tcl_GetString(objv[i]); Tcl_DStringInit(&pkgName); Tcl_DStringInit(&tmp); @@ -600,12 +593,12 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * Scan through the packages that are currently loaded to see if the - * package we want is already loaded. We'll use a loaded package if - * it meets any of the following conditions: + * package we want is already loaded. We'll use a loaded package if it + * meets any of the following conditions: * - Its name and file match the once we're looking for. * - Its file matches, and we weren't given a name. - * - Its name matches, the file name was specified as empty, and there - * is only no statically loaded package with the same name. + * - Its name matches, the file name was specified as empty, and there is + * only no statically loaded package with the same name. */ Tcl_MutexLock(&packageMutex); @@ -657,8 +650,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } if (pkgPtr == NULL) { /* - * The DLL pointed by the provided filename has never been - * loaded. + * The DLL pointed by the provided filename has never been loaded. */ Tcl_AppendResult(interp, "file \"", fullFileName, @@ -669,8 +661,8 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * Scan through the list of packages already loaded in the target - * interpreter. If the package we want is already loaded there, - * then we should proceed with unloading. + * interpreter. If the package we want is already loaded there, then we + * should proceed with unloading. */ code = TCL_ERROR; @@ -688,6 +680,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * The package has not been loaded in this interpreter. */ + Tcl_AppendResult(interp, "file \"", fullFileName, "\" has never been loaded in this interpreter", (char *) NULL); code = TCL_ERROR; @@ -695,10 +688,9 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } /* - * Ensure that the DLL can be unloaded. If it is a trusted - * interpreter, pkgPtr->unloadProc must not be NULL for the DLL to - * be unloadable. If the interpreter is a safe one, - * pkgPtr->safeUnloadProc must be non-NULL. + * Ensure that the DLL can be unloaded. If it is a trusted interpreter, + * pkgPtr->unloadProc must not be NULL for the DLL to be unloadable. If + * the interpreter is a safe one, pkgPtr->safeUnloadProc must be non-NULL. */ if (Tcl_IsSafe(target)) { @@ -723,13 +715,12 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) /* * We are ready to unload the package. First, evaluate the unload - * procedure. If this fails, we cannot proceed with unload. Also, - * we must specify the proper flag to pass to the unload callback. - * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback - * should only remove itself from the interpreter; the library - * will be unloaded in a future call of unload. In case the - * library will be unloaded just after the callback returns, - * TCL_UNLOAD_DETACH_FROM_PROCESS is passed. + * procedure. If this fails, we cannot proceed with unload. Also, we must + * specify the proper flag to pass to the unload callback. + * TCL_UNLOAD_DETACH_FROM_INTERPRETER is defined when the callback should + * only remove itself from the interpreter; the library will be unloaded + * in a future call of unload. In case the library will be unloaded just + * after the callback returns, TCL_UNLOAD_DETACH_FROM_PROCESS is passed. */ code = TCL_UNLOAD_DETACH_FROM_INTERPRETER; @@ -756,24 +747,28 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } /* - * The unload procedure executed fine. Examine the reference - * count to see if we unload the DLL. + * The unload procedure executed fine. Examine the reference count to see + * if we unload the DLL. */ Tcl_MutexLock(&packageMutex); if (Tcl_IsSafe(target)) { --pkgPtr->safeInterpRefCount; + /* - * Do not let counter get negative + * Do not let counter get negative. */ + if (pkgPtr->safeInterpRefCount < 0) { pkgPtr->safeInterpRefCount = 0; } } else { --pkgPtr->interpRefCount; + /* - * Do not let counter get negative + * Do not let counter get negative. */ + if (pkgPtr->interpRefCount < 0) { pkgPtr->interpRefCount = 0; } @@ -791,10 +786,10 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* - * Some Unix dlls are poorly behaved - registering things like - * atexit calls that can't be unregistered. If you unload - * such dlls, you get a core on exit because it wants to call - * a function in the dll after it's been unloaded. + * Some Unix dlls are poorly behaved - registering things like atexit + * calls that can't be unregistered. If you unload such dlls, you get + * a core on exit because it wants to call a function in the dll after + * it's been unloaded. */ if (pkgPtr->fileName[0] != '\0') { @@ -822,8 +817,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) } /* - * Remove this library from the interpreter's library - * cache. + * Remove this library from the interpreter's library cache. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(target, @@ -863,7 +857,7 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) #endif } - done: + done: Tcl_DStringFree(&pkgName); Tcl_DStringFree(&tmp); if (!complain && code!=TCL_OK) { @@ -873,8 +867,8 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) if (code == TCL_OK) { #if 0 /* - * Result of [unload] was not documented in TIP#100, so force - * to be the empty string by commenting this out. DKF. + * Result of [unload] was not documented in TIP#100, so force to be + * the empty string by commenting this out. DKF. */ Tcl_Obj *resultObjPtr, *objPtr[2]; @@ -908,37 +902,37 @@ Tcl_UnloadObjCmd(dummy, interp, objc, objv) * * Tcl_StaticPackage -- * - * This procedure is invoked to indicate that a particular - * package has been linked statically with an application. + * This procedure is invoked to indicate that a particular package has + * been linked statically with an application. * * Results: * None. * * Side effects: - * Once this procedure completes, the package becomes loadable - * via the "load" command with an empty file name. + * Once this procedure completes, the package becomes loadable via the + * "load" command with an empty file name. * *---------------------------------------------------------------------- */ void Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) - Tcl_Interp *interp; /* If not NULL, it means that the - * package has already been loaded - * into the given interpreter by - * calling the appropriate init proc. */ - CONST char *pkgName; /* Name of package (must be properly - * capitalized: first letter upper - * case, others lower case). */ - Tcl_PackageInitProc *initProc; /* Procedure to call to incorporate - * this package into a trusted - * interpreter. */ - Tcl_PackageInitProc *safeInitProc; /* Procedure to call to incorporate - * this package into a safe interpreter - * (one that will execute untrusted - * scripts). NULL means the package - * can't be used in safe - * interpreters. */ + Tcl_Interp *interp; /* If not NULL, it means that the package has + * already been loaded into the given + * interpreter by calling the appropriate init + * proc. */ + CONST char *pkgName; /* Name of package (must be properly + * capitalized: first letter upper case, + * others lower case). */ + Tcl_PackageInitProc *initProc; + /* Procedure to call to incorporate this + * package into a trusted interpreter. */ + Tcl_PackageInitProc *safeInitProc; + /* Procedure to call to incorporate this + * package into a safe interpreter (one that + * will execute untrusted scripts). NULL means + * the package can't be used in safe + * interpreters. */ { LoadedPackage *pkgPtr; InterpPackage *ipPtr, *ipFirstPtr; @@ -959,8 +953,8 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) Tcl_MutexUnlock(&packageMutex); /* - * If the package is not yet recorded as being loaded statically, - * add it to the list now. + * If the package is not yet recorded as being loaded statically, add it + * to the list now. */ if ( pkgPtr == NULL ) { @@ -982,8 +976,8 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) if (interp != NULL) { /* - * If we're loading the package into an interpreter, - * determine whether it's already loaded. + * If we're loading the package into an interpreter, determine whether + * it's already loaded. */ ipFirstPtr = (InterpPackage *) Tcl_GetAssocData(interp, "tclLoad", @@ -995,8 +989,8 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) } /* - * Package isn't loade in the current interp yet. Mark it as - * now being loaded. + * Package isn't loade in the current interp yet. Mark it as now being + * loaded. */ ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage)); @@ -1012,17 +1006,15 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) * * TclGetLoadedPackages -- * - * This procedure returns information about all of the files - * that are loaded (either in a particular intepreter, or - * for all interpreters). + * This procedure returns information about all of the files that are + * loaded (either in a particular intepreter, or for all interpreters). * * Results: - * The return value is a standard Tcl completion code. If - * successful, a list of lists is placed in the interp's result. - * Each sublist corresponds to one loaded file; its first - * element is the name of the file (or an empty string for - * something that's statically loaded) and the second element - * is the name of the package in that file. + * The return value is a standard Tcl completion code. If successful, a + * list of lists is placed in the interp's result. Each sublist + * corresponds to one loaded file; its first element is the name of the + * file (or an empty string for something that's statically loaded) and + * the second element is the name of the package in that file. * * Side effects: * None. @@ -1032,10 +1024,10 @@ Tcl_StaticPackage(interp, pkgName, initProc, safeInitProc) int TclGetLoadedPackages(interp, targetName) - Tcl_Interp *interp; /* Interpreter in which to return - * information or error message. */ - char *targetName; /* Name of target interpreter or NULL. - * If NULL, return info about all interps; + Tcl_Interp *interp; /* Interpreter in which to return information + * or error message. */ + char *targetName; /* Name of target interpreter or NULL. If + * NULL, return info about all interps; * otherwise, just return info about this * interpreter. */ { @@ -1045,7 +1037,7 @@ TclGetLoadedPackages(interp, targetName) char *prefix; if (targetName == NULL) { - /* + /* * Return information about all of the available packages. */ @@ -1064,8 +1056,8 @@ TclGetLoadedPackages(interp, targetName) } /* - * Return information about only the packages that are loaded in - * a given interpreter. + * Return information about only the packages that are loaded in a given + * interpreter. */ target = Tcl_GetSlave(interp, targetName); @@ -1091,16 +1083,16 @@ TclGetLoadedPackages(interp, targetName) * * LoadCleanupProc -- * - * This procedure is called to delete all of the InterpPackage - * structures for an interpreter when the interpreter is deleted. - * It gets invoked via the Tcl AssocData mechanism. + * This procedure is called to delete all of the InterpPackage structures + * for an interpreter when the interpreter is deleted. It gets invoked + * via the Tcl AssocData mechanism. * * Results: * None. * * Side effects: - * Storage for all of the InterpPackage procedures for interp - * get deleted. + * Storage for all of the InterpPackage procedures for interp get + * deleted. * *---------------------------------------------------------------------- */ @@ -1126,8 +1118,8 @@ LoadCleanupProc(clientData, interp) * * TclFinalizeLoad -- * - * This procedure is invoked just before the application exits. - * It frees all of the LoadedPackage structures. + * This procedure is invoked just before the application exits. It frees + * all of the LoadedPackage structures. * * Results: * None. @@ -1144,33 +1136,42 @@ TclFinalizeLoad() LoadedPackage *pkgPtr; /* - * No synchronization here because there should just be - * one thread alive at this point. Logically, - * packageMutex should be grabbed at this point, but - * the Mutexes get finalized before the call to this routine. - * The only subsystem left alive at this point is the - * memory allocator. + * No synchronization here because there should just be one thread alive + * at this point. Logically, packageMutex should be grabbed at this point, + * but the Mutexes get finalized before the call to this routine. The + * only subsystem left alive at this point is the memory allocator. */ while (firstPackagePtr != NULL) { pkgPtr = firstPackagePtr; firstPackagePtr = pkgPtr->nextPtr; + #if defined(TCL_UNLOAD_DLLS) || defined(__WIN32__) /* - * Some Unix dlls are poorly behaved - registering things like - * atexit calls that can't be unregistered. If you unload - * such dlls, you get a core on exit because it wants to - * call a function in the dll after it's been unloaded. + * Some Unix dlls are poorly behaved - registering things like atexit + * calls that can't be unregistered. If you unload such dlls, you get + * a core on exit because it wants to call a function in the dll after + * it's been unloaded. */ + if (pkgPtr->fileName[0] != '\0') { Tcl_FSUnloadFileProc *unLoadProcPtr = pkgPtr->unLoadProcPtr; if (unLoadProcPtr != NULL) { - (*unLoadProcPtr)(pkgPtr->loadHandle); + (*unLoadProcPtr)(pkgPtr->loadHandle); } } #endif + ckfree(pkgPtr->fileName); ckfree(pkgPtr->packageName); ckfree((char *) pkgPtr); } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index e9a9494..9230cf0 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -21,7 +21,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclNamesp.c,v 1.79 2005/07/15 15:53:52 dkf Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.80 2005/07/17 21:17:43 dkf Exp $ */ #include "tclInt.h" @@ -459,7 +459,7 @@ Tcl_PushCallFrame(interp, callFramePtr, namespacePtr, isProcCallFrame) } else { framePtr->level = 1; } - framePtr->procPtr = NULL; /* no called procedure */ + framePtr->procPtr = NULL; /* no called procedure */ framePtr->varTablePtr = NULL; /* and no local variables */ framePtr->numCompiledLocals = 0; framePtr->compiledLocals = NULL; @@ -741,18 +741,17 @@ ErrorInfoRead(clientData, interp, name1, name2, flags) Tcl_Namespace * Tcl_CreateNamespace(interp, name, clientData, deleteProc) - Tcl_Interp *interp; /* Interpreter in which a new namespace is - * being created. Also used for error - * reporting. */ - CONST char *name; /* Name for the new namespace. May be a - * qualified name with names of ancestor - * namespaces separated by "::"s. */ - ClientData clientData; /* One-word value to store with - * namespace. */ + Tcl_Interp *interp; /* Interpreter in which a new namespace is + * being created. Also used for error + * reporting. */ + CONST char *name; /* Name for the new namespace. May be a + * qualified name with names of ancestor + * namespaces separated by "::"s. */ + ClientData clientData; /* One-word value to store with namespace. */ Tcl_NamespaceDeleteProc *deleteProc; - /* Function called to delete client data - * when the namespace is deleted. NULL if - * no function should be called. */ + /* Function called to delete client data when + * the namespace is deleted. NULL if no + * function should be called. */ { Interp *iPtr = (Interp *) interp; register Namespace *nsPtr, *ancestorPtr; @@ -807,7 +806,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc) if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) { Tcl_AppendResult(interp, "can't create namespace \"", name, - "\": already exists", (char *) NULL); + "\": already exists", (char *) NULL); return NULL; } } @@ -924,18 +923,19 @@ Tcl_DeleteNamespace(namespacePtr) Tcl_HashEntry *entryPtr; /* - * If the namespace has associated ensemble commands, delete them - * first. This leaves the actual contents of the namespace alone - * (unless they are linked ensemble commands, of course.) Note - * that this code is actually reentrant so command delete traces - * won't purturb things badly. + * If the namespace has associated ensemble commands, delete them first. + * This leaves the actual contents of the namespace alone (unless they are + * linked ensemble commands, of course.) Note that this code is actually + * reentrant so command delete traces won't purturb things badly. */ while (nsPtr->ensembles != NULL) { + EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; + /* * Splice out and link to indicate that we've already been killed. */ - EnsembleConfig *ensemblePtr = (EnsembleConfig *) nsPtr->ensembles; + nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr->next; ensemblePtr->next = ensemblePtr; Tcl_DeleteCommandFromToken(nsPtr->interp, ensemblePtr->token); @@ -1353,12 +1353,12 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst) int Tcl_AppendExportList(interp, namespacePtr, objPtr) - Tcl_Interp *interp; /* Interpreter used for error reporting. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace whose export - * pattern list is appended onto objPtr. - * NULL for the current namespace. */ - Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * export pattern list is appended. */ + Tcl_Interp *interp; /* Interpreter used for error reporting. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace whose export + * pattern list is appended onto objPtr. NULL + * for the current namespace. */ + Tcl_Obj *objPtr; /* Points to the Tcl object onto which the + * export pattern list is appended. */ { Namespace *nsPtr; int i, result; @@ -1415,18 +1415,18 @@ Tcl_AppendExportList(interp, namespacePtr, objPtr) int Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace into which the - * commands are to be imported. NULL for the - * current namespace. */ - CONST char *pattern; /* String pattern indicating which commands - * to import. This pattern should be - * qualified by the name of the namespace - * from which to import the command(s). */ - int allowOverwrite; /* If nonzero, allow existing commands to be - * overwritten by imported commands. If 0, - * return an error if an imported cmd - * conflicts with an existing one. */ + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace into which the + * commands are to be imported. NULL for the + * current namespace. */ + CONST char *pattern; /* String pattern indicating which commands to + * import. This pattern should be qualified by + * the name of the namespace from which to + * import the command(s). */ + int allowOverwrite; /* If nonzero, allow existing commands to be + * overwritten by imported commands. If 0, + * return an error if an imported cmd + * conflicts with an existing one. */ { Namespace *nsPtr, *importNsPtr, *dummyPtr; CONST char *simplePattern; @@ -1445,8 +1445,8 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) /* * First, invoke the "auto_import" command with the pattern being - * imported. This command is part of the Tcl library. It looks for - * imported commands in autoloaded libraries and loads them in. That way, + * imported. This command is part of the Tcl library. It looks for + * imported commands in autoloaded libraries and loads them in. That way, * they will be found when we try to create links below. * * Note that we don't just call Tcl_EvalObjv() directly because we do not @@ -1529,6 +1529,25 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite) } return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * DoImport -- + * + * Import a particular command from one namespace into another. Helper + * for Tcl_Import(). + * + * Results: + * Standard Tcl result code. If TCL_ERROR, appends an error message to + * the interpreter result. + * + * Side effects: + * A new command is created in the target namespace unless this is a + * reimport of exactly the same command as before. + * + *---------------------------------------------------------------------- + */ static int DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) @@ -1648,19 +1667,19 @@ DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) * * Deletes commands previously imported into the namespace indicated. * The by namespacePtr, or the current namespace of interp, when - * namespacePtr is NULL. The pattern controls which imported commands - * are deleted. A simple pattern, one without namespace separators, - * matches the current command names of imported commands in the - * namespace. Matching imported commands are deleted. A qualified pattern - * is interpreted as deletion selection on the basis of where the command - * is imported from. The original command and "first link" command for - * each imported command are determined, and they are matched against the - * pattern. A match leads to deletion of the imported command. + * namespacePtr is NULL. The pattern controls which imported commands are + * deleted. A simple pattern, one without namespace separators, matches + * the current command names of imported commands in the namespace. + * Matching imported commands are deleted. A qualified pattern is + * interpreted as deletion selection on the basis of where the command is + * imported from. The original command and "first link" command for each + * imported command are determined, and they are matched against the + * pattern. A match leads to deletion of the imported command. * * Results: - * Returns TCL_ERROR and records an error message in the interp result if - * a namespace qualified pattern refers to a namespace that does not - * exist. Otherwise, returns TCL_OK. + * Returns TCL_ERROR and records an error message in the interp result if + * a namespace qualified pattern refers to a namespace that does not + * exist. Otherwise, returns TCL_OK. * * Side effects: * May delete commands. @@ -1670,12 +1689,12 @@ DoImport(interp, nsPtr, hPtr, cmdName, pattern, importNsPtr, allowOverwrite) int Tcl_ForgetImport(interp, namespacePtr, pattern) - Tcl_Interp *interp; /* Current interpreter. */ - Tcl_Namespace *namespacePtr; /* Points to the namespace from which - * previously imported commands should be - * removed. NULL for current namespace. */ - CONST char *pattern; /* String pattern indicating which imported - * commands to remove. */ + Tcl_Interp *interp; /* Current interpreter. */ + Tcl_Namespace *namespacePtr;/* Points to the namespace from which + * previously imported commands should be + * removed. NULL for current namespace. */ + CONST char *pattern; /* String pattern indicating which imported + * commands to remove. */ { Namespace *nsPtr, *sourceNsPtr, *dummyPtr; CONST char *simplePattern; @@ -1989,43 +2008,41 @@ DeleteImportedCmd(clientData) int TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtrPtr, altNsPtrPtr, actualCxtPtrPtr, simpleNamePtr) - Tcl_Interp *interp; /* Interpreter in which to find the namespace - * containing qualName. */ - CONST char *qualName; /* A namespace-qualified name of an command, - * variable, or namespace. */ - Namespace *cxtNsPtr; /* The namespace in which to start the search - * for qualName's namespace. If NULL start - * from the current namespace. Ignored if - * TCL_GLOBAL_ONLY is set. */ - int flags; /* Flags controlling the search: an OR'd - * combination of TCL_GLOBAL_ONLY, - * TCL_NAMESPACE_ONLY, - * TCL_CREATE_NS_IF_UNKNOWN, and - * TCL_FIND_ONLY_NS. */ - Namespace **nsPtrPtr; /* Address where function stores a pointer to - * containing namespace if qualName is found - * starting from *cxtNsPtr or, if - * TCL_GLOBAL_ONLY is set, if qualName is - * found in the global :: namespace. NULL is - * stored otherwise. */ - Namespace **altNsPtrPtr; /* Address where function stores a pointer to - * containing namespace if qualName is found - * starting from the global :: namespace. - * NULL is stored if qualName isn't found - * starting from :: or if the - * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, - * TCL_CREATE_NS_IF_UNKNOWN, TCL_FIND_ONLY_NS - * flag is set. */ - Namespace **actualCxtPtrPtr; /* Address where function stores a pointer to - * the actual namespace from which the search - * started. This is either cxtNsPtr, the :: - * namespace if TCL_GLOBAL_ONLY was - * specified, or the current namespace if - * cxtNsPtr was NULL. */ - CONST char **simpleNamePtr; /* Address where function stores the simple - * name at end of the qualName, or NULL if - * qualName is "::" or the flag - * TCL_FIND_ONLY_NS was specified. */ + Tcl_Interp *interp; /* Interpreter in which to find the namespace + * containing qualName. */ + CONST char *qualName; /* A namespace-qualified name of an command, + * variable, or namespace. */ + Namespace *cxtNsPtr; /* The namespace in which to start the search + * for qualName's namespace. If NULL start + * from the current namespace. Ignored if + * TCL_GLOBAL_ONLY is set. */ + int flags; /* Flags controlling the search: an OR'd + * combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, and + * TCL_CREATE_NS_IF_UNKNOWN. */ + Namespace **nsPtrPtr; /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from *cxtNsPtr or, if + * TCL_GLOBAL_ONLY is set, if qualName is + * found in the global :: namespace. NULL is + * stored otherwise. */ + Namespace **altNsPtrPtr; /* Address where function stores a pointer to + * containing namespace if qualName is found + * starting from the global :: namespace. + * NULL is stored if qualName isn't found + * starting from :: or if the TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY, TCL_FIND_ONLY_NS, + * TCL_CREATE_NS_IF_UNKNOWN flag is set. */ + Namespace **actualCxtPtrPtr;/* Address where function stores a pointer to + * the actual namespace from which the search + * started. This is either cxtNsPtr, the :: + * namespace if TCL_GLOBAL_ONLY was specified, + * or the current namespace if cxtNsPtr was + * NULL. */ + CONST char **simpleNamePtr; /* Address where function stores the simple + * name at end of the qualName, or NULL if + * qualName is "::" or the flag + * TCL_FIND_ONLY_NS was specified. */ { Interp *iPtr = (Interp *) interp; Namespace *nsPtr = cxtNsPtr; @@ -2222,7 +2239,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, nsPtr = NULL; } - *nsPtrPtr = nsPtr; + *nsPtrPtr = nsPtr; *altNsPtrPtr = altNsPtr; Tcl_DStringFree(&buffer); return TCL_OK; @@ -2248,21 +2265,21 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags, Tcl_Namespace * Tcl_FindNamespace(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * namespace. */ - CONST char *name; /* Namespace name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag is set or - * if the name starts with "::". Otherwise, - * points to namespace in which to resolve - * name; if NULL, look up name in the current - * namespace. */ - register int flags; /* Flags controlling namespace lookup: an - * OR'd combination of TCL_GLOBAL_ONLY and - * TCL_LEAVE_ERR_MSG flags. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * namespace. */ + CONST char *name; /* Namespace name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag is set or + * if the name starts with "::". Otherwise, + * points to namespace in which to resolve + * name; if NULL, look up name in the current + * namespace. */ + register int flags; /* Flags controlling namespace lookup: an OR'd + * combination of TCL_GLOBAL_ONLY and + * TCL_LEAVE_ERR_MSG flags. */ { Namespace *nsPtr, *dummy1Ptr, *dummy2Ptr; CONST char *dummy; @@ -2280,8 +2297,8 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) return (Tcl_Namespace *) nsPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown namespace \"", name, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown namespace \"", name, "\"", + (char *) NULL); } return NULL; } @@ -2307,25 +2324,25 @@ Tcl_FindNamespace(interp, name, contextNsPtr, flags) Tcl_Command Tcl_FindCommand(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * command and to report errors. */ - CONST char *name; /* Command's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which to - * resolve name. If NULL, look up name in the - * current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are - * given, TCL_GLOBAL_ONLY is ignored. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * command and to report errors. */ + CONST char *name; /* Command's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; Namespace *cxtNsPtr; @@ -2490,25 +2507,25 @@ Tcl_FindCommand(interp, name, contextNsPtr, flags) Tcl_Var Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) - Tcl_Interp *interp; /* The interpreter in which to find the - * variable. */ - CONST char *name; /* Variable's name. If it starts with "::", - * will be looked up in global namespace. - * Else, looked up first in contextNsPtr - * (current namespace if contextNsPtr is - * NULL), then in global namespace. */ - Tcl_Namespace *contextNsPtr; /* Ignored if TCL_GLOBAL_ONLY flag set. - * Otherwise, points to namespace in which to - * resolve name. If NULL, look up name in the - * current namespace. */ - int flags; /* An OR'd combination of flags: - * TCL_GLOBAL_ONLY (look up name only in - * global namespace), TCL_NAMESPACE_ONLY - * (look up only in contextNsPtr, or the - * current namespace if contextNsPtr is - * NULL), and TCL_LEAVE_ERR_MSG. If both - * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY are - * given, TCL_GLOBAL_ONLY is ignored. */ + Tcl_Interp *interp; /* The interpreter in which to find the + * variable. */ + CONST char *name; /* Variable's name. If it starts with "::", + * will be looked up in global namespace. + * Else, looked up first in contextNsPtr + * (current namespace if contextNsPtr is + * NULL), then in global namespace. */ + Tcl_Namespace *contextNsPtr;/* Ignored if TCL_GLOBAL_ONLY flag set. + * Otherwise, points to namespace in which to + * resolve name. If NULL, look up name in the + * current namespace. */ + int flags; /* An OR'd combination of flags: + * TCL_GLOBAL_ONLY (look up name only in + * global namespace), TCL_NAMESPACE_ONLY (look + * up only in contextNsPtr, or the current + * namespace if contextNsPtr is NULL), and + * TCL_LEAVE_ERR_MSG. If both TCL_GLOBAL_ONLY + * and TCL_NAMESPACE_ONLY are given, + * TCL_GLOBAL_ONLY is ignored. */ { Interp *iPtr = (Interp*)interp; ResolverScheme *resPtr; @@ -2585,8 +2602,8 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) return (Tcl_Var) varPtr; } else if (flags & TCL_LEAVE_ERR_MSG) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "unknown variable \"", name, - "\"", (char *) NULL); + Tcl_AppendResult(interp, "unknown variable \"", name, "\"", + (char *) NULL); } return (Tcl_Var) NULL; } @@ -2600,10 +2617,10 @@ Tcl_FindNamespaceVar(interp, name, contextNsPtr, flags) * command references that the new command may invalidate. Consider the * following cases that could happen when you add a command "foo" to a * namespace "b": - * 1. It could shadow a command named "foo" at the global scope. If + * 1. It could shadow a command named "foo" at the global scope. If * it does, all command references in the namespace "b" are * suspect. - * 2. Suppose the namespace "b" resides in a namespace "a". Then to + * 2. Suppose the namespace "b" resides in a namespace "a". Then to * "a" the new command "b::foo" could shadow another command * "b::foo" in the global namespace. If so, then all command * references in "a" * are suspect. @@ -3385,8 +3402,8 @@ NamespaceEvalCmd(dummy, interp, objc, objv) } /* - * Make the specified namespace the current namespace and evaluate - * the command(s). + * Make the specified namespace the current namespace and evaluate the + * command(s). */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ @@ -3397,7 +3414,8 @@ NamespaceEvalCmd(dummy, interp, objc, objv) return TCL_ERROR; } framePtr->objc = objc; - framePtr->objv = objv; /* ref counts do not need to be incremented here */ + framePtr->objv = objv; /* Reference counts do not need to be + * incremented here. */ if (objc == 4) { result = Tcl_EvalObjEx(interp, objv[3], 0); @@ -3439,9 +3457,9 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * * NamespaceExistsCmd -- * - * Invoked to implement the "namespace exists" command that returns - * true if the given namespace currently exists, and false otherwise. - * Handles the following syntax: + * Invoked to implement the "namespace exists" command that returns true + * if the given namespace currently exists, and false otherwise. Handles + * the following syntax: * * namespace exists name * @@ -3449,8 +3467,8 @@ NamespaceEvalCmd(dummy, interp, objc, objv) * Returns TCL_OK if successful, and TCL_ERROR if anything goes wrong. * * Side effects: - * Returns a result in the interpreter's result object. If anything - * goes wrong, the result is an error message. + * Returns a result in the interpreter's result object. If anything goes + * wrong, the result is an error message. * *---------------------------------------------------------------------- */ @@ -3738,11 +3756,11 @@ NamespaceImportCmd(dummy, interp, objc, objv) * arguments after the first onto the end as proper list elements. For * example, * - * namespace inscope ::foo a b c d + * namespace inscope ::foo {a b} c d e * * is equivalent to * - * namespace eval ::foo [concat a [list b c d]] + * namespace eval ::foo [concat {a b} [list c d e]] * * This lappend semantics is important because many callback scripts are * actually prefixes. @@ -4287,11 +4305,11 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv) * Invoked to implement the "namespace tail" command that returns the * trailing name at the end of a string with "::" namespace qualifiers. * These qualifiers are namespace names separated by "::"s. For example, - * for "::foo::p" this command returns "p", and for "::" it returns - * "". This command is the complement of the "namespace qualifiers" - * command. Note that this command does not check whether the "namespace" - * names are, in fact, the names of currently defined namespaces. Handles - * the following syntax: + * for "::foo::p" this command returns "p", and for "::" it returns "". + * This command is the complement of the "namespace qualifiers" command. + * Note that this command does not check whether the "namespace" names + * are, in fact, the names of currently defined namespaces. Handles the + * following syntax: * * namespace tail string * @@ -4365,7 +4383,7 @@ NamespaceTailCmd(dummy, interp, objc, objv) static int NamespaceWhichCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ + ClientData dummy; /* Not used. */ Tcl_Interp *interp; /* Current interpreter. */ int objc; /* Number of arguments. */ Tcl_Obj *CONST objv[]; /* Argument objects. */ @@ -4390,6 +4408,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) /* * Preserve old style of error message! */ + Tcl_ResetResult(interp); goto badArgs; } @@ -4399,6 +4418,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) switch (lookupType) { case 0: { /* -command */ Tcl_Command cmd = Tcl_GetCommandFromObj(interp, objv[objc-1]); + if (cmd != (Tcl_Command) NULL) { Tcl_GetCommandFullName(interp, cmd, resultPtr); } @@ -4407,6 +4427,7 @@ NamespaceWhichCmd(dummy, interp, objc, objv) case 1: { /* -variable */ Tcl_Var var = Tcl_FindNamespaceVar(interp, TclGetString(objv[objc-1]), NULL, /*flags*/ 0); + if (var != (Tcl_Var) NULL) { Tcl_GetVariableFullName(interp, var, resultPtr); } @@ -4876,6 +4897,7 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv) /* * Tricky! Rely on the object result not being shared! */ + Tcl_GetCommandFullName(interp, token, Tcl_GetObjResult(interp)); return TCL_OK; } @@ -5006,10 +5028,7 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv) Tcl_DictSearch search; Tcl_Obj *listObj; int done, len, allocatedMapFlag = 0; - /* - * Defaults - */ - Tcl_Obj *subcmdObj, *mapObj, *unknownObj; + Tcl_Obj *subcmdObj, *mapObj, *unknownObj; /* Defaults */ int permitPrefix, flags; Tcl_GetEnsembleSubcommandList(NULL, token, &subcmdObj); @@ -5048,9 +5067,11 @@ NamespaceEnsembleCmd(dummy, interp, objc, objv) continue; case CONF_MAP: { Tcl_Obj *patchedDict = NULL, *subcmdObj; + /* * Verify that the map is sensible. */ + if (Tcl_DictObjFirst(interp, objv[1], &search, &subcmdObj, &listObj, &done) != TCL_OK) { if (allocatedMapFlag) { @@ -5708,14 +5729,12 @@ Tcl_GetEnsembleNamespace(interp, token, namespacePtrPtr) Tcl_Command Tcl_FindEnsemble(interp, cmdNameObj, flags) - Tcl_Interp *interp; /* Where to do the lookup, and where - * to write the errors if - * TCL_LEAVE_ERR_MSG is set in the - * flags. */ - Tcl_Obj *cmdNameObj; /* Name of command to look up. */ - int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; - * other flags are probably not - * useful. */ + Tcl_Interp *interp; /* Where to do the lookup, and where to write + * the errors if TCL_LEAVE_ERR_MSG is set in + * the flags. */ + Tcl_Obj *cmdNameObj; /* Name of command to look up. */ + int flags; /* Either 0 or TCL_LEAVE_ERR_MSG; other flags + * are probably not useful. */ { Command *cmdPtr; @@ -5724,6 +5743,7 @@ Tcl_FindEnsemble(interp, cmdNameObj, flags) if (cmdPtr == NULL) { return NULL; } + if (cmdPtr->objProc != NsEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains @@ -5740,6 +5760,7 @@ Tcl_FindEnsemble(interp, cmdNameObj, flags) return NULL; } } + return (Tcl_Command) cmdPtr; } @@ -5805,23 +5826,21 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) Tcl_Obj *CONST objv[]; { EnsembleConfig *ensemblePtr = (EnsembleConfig *) clientData; - /* The ensemble itself. */ - Tcl_Obj **tempObjv; /* Space used to construct the list of - * arguments to pass to the command - * that implements the ensemble - * subcommand. */ - int result; /* The result of the subcommand - * execution. */ - Tcl_Obj *prefixObj; /* An object containing the prefix - * words of the command that - * implements the subcommand. */ - Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully - * specified but not yet cached - * command names. */ - Tcl_Obj **prefixObjv; /* The list of objects to substitute - * in as the target command prefix. */ - int prefixObjc; /* Size of prefixObjv of course! */ - int reparseCount = 0; /* Number of reparses. */ + /* The ensemble itself. */ + Tcl_Obj **tempObjv; /* Space used to construct the list of + * arguments to pass to the command that + * implements the ensemble subcommand. */ + int result; /* The result of the subcommand execution. */ + Tcl_Obj *prefixObj; /* An object containing the prefix words of + * the command that implements the + * subcommand. */ + Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully + * specified but not yet cached command + * names. */ + Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the + * target command prefix. */ + int prefixObjc; /* Size of prefixObjv of course! */ + int reparseCount = 0; /* Number of reparses. */ if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument ...?"); @@ -5885,6 +5904,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) /* * Can't find and we are prohibited from using unambiguous prefixes. */ + goto unknownOrAmbiguousSubcommand; } else { /* @@ -5893,10 +5913,10 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) * matches. */ - char *subcmdName; /* Name of the subcommand, or unique - * prefix of it (will be an error for - * a non-unique prefix). */ - char *fullName = NULL; /* Full name of the subcommand. */ + char *subcmdName; /* Name of the subcommand, or unique prefix of + * it (will be an error for a non-unique + * prefix). */ + char *fullName = NULL; /* Full name of the subcommand. */ int stringLength, i; int tableLength = ensemblePtr->subcommandTable.numEntries; @@ -5914,6 +5934,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) * our subcommand is an ambiguous prefix of (at least) two * exported subcommands, which is an error case. */ + goto unknownOrAmbiguousSubcommand; } fullName = ensemblePtr->subcommandArrayPtr[i]; @@ -5923,6 +5944,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) * searching because we have gone past anything that could * possibly match. */ + break; } } @@ -5930,6 +5952,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) /* * The subcommand is not a prefix of anything, so bail out! */ + goto unknownOrAmbiguousSubcommand; } hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, fullName); @@ -6069,6 +6092,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) break; default: { char buf[TCL_INTEGER_SPACE]; + sprintf(buf, "%d", result); Tcl_AppendResult(interp, buf, NULL); } @@ -6095,7 +6119,7 @@ NsEnsembleImplementationCmd(clientData, interp, objc, objv) Tcl_ResetResult(interp); if (ensemblePtr->subcommandTable.numEntries == 0) { - Tcl_AppendResult(interp, "unknown subcommand \"", TclGetString(objv[1]), + Tcl_AppendResult(interp, "unknown subcommand \"",TclGetString(objv[1]), "\": namespace ", ensemblePtr->nsPtr->fullName, " does not export any commands", NULL); return TCL_ERROR; @@ -6159,6 +6183,7 @@ MakeCachedEnsembleCommand(objPtr, ensemblePtr, subcommandName, prefixObjPtr) * Kill the old internal rep, and replace it with a brand new one of * our own. */ + TclFreeIntRep(objPtr); ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep)); objPtr->internalRep.otherValuePtr = (VOID *) ensembleCmd; @@ -6296,9 +6321,9 @@ static void BuildEnsembleConfig(ensemblePtr) EnsembleConfig *ensemblePtr; { - Tcl_HashSearch search; /* Used for scanning the set of - * commands in the namespace that - * backs up this ensemble. */ + Tcl_HashSearch search; /* Used for scanning the set of commands in + * the namespace that backs up this + * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; @@ -6307,6 +6332,7 @@ BuildEnsembleConfig(ensemblePtr) /* * Remove pre-existing table. */ + Tcl_HashSearch search; ckfree((char *)ensemblePtr->subcommandArrayPtr); @@ -6630,3 +6656,11 @@ StringOfEnsembleCmdRep(objPtr) objPtr->bytes = ckalloc((unsigned) length+1); memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1); } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclObj.c b/generic/tclObj.c index d70ae28..3271811 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -1,18 +1,18 @@ /* * tclObj.c -- * - * This file contains Tcl object-related procedures that are used by - * many Tcl commands. + * This file contains Tcl object-related procedures that are used by many + * Tcl commands. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. * Copyright (c) 2001 by ActiveState Corporation. * Copyright (c) 2005 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. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclObj.c,v 1.87 2005/06/07 21:14:29 dgp Exp $ + * RCS: @(#) $Id: tclObj.c,v 1.88 2005/07/17 21:17:44 dkf Exp $ */ #include "tclInt.h" @@ -45,8 +45,8 @@ TCL_DECLARE_MUTEX(tableMutex) Tcl_Obj *tclFreeObjList = NULL; /* - * The object allocator is single threaded. This mutex is referenced - * by the TclNewObj macro, however, so must be visible. + * The object allocator is single threaded. This mutex is referenced by the + * TclNewObj macro, however, so must be visible. */ #ifdef TCL_THREADS @@ -54,9 +54,9 @@ Tcl_Mutex tclObjMutex; #endif /* - * Pointer to a heap-allocated string of length zero that the Tcl core uses - * as the value of an empty string representation for an object. This value - * is shared by all new objects allocated by Tcl_NewObj. + * Pointer to a heap-allocated string of length zero that the Tcl core uses as + * the value of an empty string representation for an object. This value is + * shared by all new objects allocated by Tcl_NewObj. */ char tclEmptyString = '\0'; @@ -64,8 +64,8 @@ char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* - * Thread local table that is used to check that a Tcl_Obj - * was not allocated by some other thread. + * Thread local table that is used to check that a Tcl_Obj was not allocated + * by some other thread. */ typedef struct ThreadSpecificData { Tcl_HashTable *objThreadMap; @@ -78,11 +78,11 @@ static Tcl_ThreadDataKey dataKey; /* * Nested Tcl_Obj deletion management support * - * All context references used in the object freeing code are pointers - * to this structure; every thread will have its own structure - * instance. The purpose of this structure is to allow deeply nested - * collections of Tcl_Objs to be freed without taking a vast depth of - * C stack (which could cause all sorts of breakage.) + * All context references used in the object freeing code are pointers to this + * structure; every thread will have its own structure instance. The purpose + * of this structure is to allow deeply nested collections of Tcl_Objs to be + * freed without taking a vast depth of C stack (which could cause all sorts + * of breakage.) */ typedef struct PendingObjData { @@ -91,34 +91,35 @@ typedef struct PendingObjData { * conceptually; many are actually expanded * macros). */ Tcl_Obj *deletionStack; /* Stack of objects that have had TclFreeObj() - * invoked upon them but which can't be deleted - * yet because they are in a nested invokation - * of TclFreeObj(). By postponing this way, we - * limit the maximum overall C stack depth when - * deleting a complex object. The down-side is - * that we alter the overall behaviour by - * altering the order in which objects are - * deleted, and we change the order in which - * the string rep and the internal rep of an - * object are deleted. Note that code which - * assumes the previous behaviour in either of - * these respects is unsafe anyway; it was - * never documented as to exactly what would - * happen in these cases, and the overall - * contract of a user-level Tcl_DecrRefCount() - * is still preserved (assuming that a - * particular T_DRC would delete an object is - * not very safe). */ + * invoked upon them but which can't be + * deleted yet because they are in a nested + * invokation of TclFreeObj(). By postponing + * this way, we limit the maximum overall C + * stack depth when deleting a complex object. + * The down-side is that we alter the overall + * behaviour by altering the order in which + * objects are deleted, and we change the + * order in which the string rep and the + * internal rep of an object are deleted. Note + * that code which assumes the previous + * behaviour in either of these respects is + * unsafe anyway; it was never documented as + * to exactly what would happen in these + * cases, and the overall contract of a + * user-level Tcl_DecrRefCount() is still + * preserved (assuming that a particular T_DRC + * would delete an object is not very + * safe). */ } PendingObjData; /* * These are separated out so that some semantic content is attached * to them. */ -#define ObjDeletionLock(contextPtr) (contextPtr)->deletionCount++ -#define ObjDeletionUnlock(contextPtr) (contextPtr)->deletionCount-- -#define ObjDeletePending(contextPtr) (contextPtr)->deletionCount > 0 -#define ObjOnStack(contextPtr) (contextPtr)->deletionStack != NULL +#define ObjDeletionLock(contextPtr) ((contextPtr)->deletionCount++) +#define ObjDeletionUnlock(contextPtr) ((contextPtr)->deletionCount--) +#define ObjDeletePending(contextPtr) ((contextPtr)->deletionCount > 0) +#define ObjOnStack(contextPtr) ((contextPtr)->deletionStack != NULL) #define PushObjToDelete(contextPtr,objPtr) \ /* Invalidate the string rep first so we can use the bytes value \ * for our pointer chain. */ \ @@ -152,23 +153,23 @@ Tcl_ThreadDataKey pendingObjDataKey; * Macros to pack/unpack a bignum's fields in a Tcl_Obj internal rep */ -#define PACK_BIGNUM( bignum, objPtr ) \ - do { \ - (objPtr)->internalRep.bignumValue.digits = (void*) (bignum).dp; \ - (objPtr)->internalRep.bignumValue.misc = ( \ - ( (bignum).sign << 30 ) \ - | ( (bignum).alloc << 15 ) \ - | ( (bignum).used ) ); \ - } while ( 0 ) +#define PACK_BIGNUM(bignum, objPtr) \ + do { \ + (objPtr)->internalRep.bignumValue.digits = (void*) (bignum).dp; \ + (objPtr)->internalRep.bignumValue.misc = ( \ + ((bignum).sign << 30) \ + | ((bignum).alloc << 15) \ + | ((bignum).used)); \ + } while (0) -#define UNPACK_BIGNUM( objPtr, bignum ) \ - do { \ - (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \ - (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \ - (bignum).alloc = ( (objPtr)->internalRep.bignumValue.misc >> 15 ) \ - & 0x7fff; \ - (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \ - } while ( 0 ) +#define UNPACK_BIGNUM(objPtr, bignum) \ + do { \ + (bignum).dp = (mp_digit*) (objPtr)->internalRep.bignumValue.digits; \ + (bignum).sign = (objPtr)->internalRep.bignumValue.misc >> 30; \ + (bignum).alloc = \ + ((objPtr)->internalRep.bignumValue.misc >> 15) & 0x7fff; \ + (bignum).used = (objPtr)->internalRep.bignumValue.misc & 0x7fff; \ + } while (0) /* * Prototypes for procedures defined later in this file: @@ -181,7 +182,7 @@ static int SetDoubleFromAny _ANSI_ARGS_((Tcl_Interp *interp, static int SetIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static int SetIntOrWideFromAny _ANSI_ARGS_((Tcl_Interp* interp, - Tcl_Obj *objPtr)); + Tcl_Obj *objPtr)); static void UpdateStringOfBoolean _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfDouble _ANSI_ARGS_((Tcl_Obj *objPtr)); static void UpdateStringOfInt _ANSI_ARGS_((Tcl_Obj *objPtr)); @@ -192,12 +193,12 @@ static int SetWideIntFromAny _ANSI_ARGS_((Tcl_Interp *interp, static void UpdateStringOfWideInt _ANSI_ARGS_((Tcl_Obj *objPtr)); #endif -static void FreeBignum _ANSI_ARGS_(( Tcl_Obj *objPtr )); -static void DupBignum _ANSI_ARGS_(( Tcl_Obj *objPtr, - Tcl_Obj *copyPtr )); -static void UpdateStringOfBignum _ANSI_ARGS_(( Tcl_Obj *objPtr )); -static int SetBignumFromAny _ANSI_ARGS_(( Tcl_Interp* interp, - Tcl_Obj* objPtr )); +static void FreeBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); +static void DupBignum _ANSI_ARGS_((Tcl_Obj *objPtr, + Tcl_Obj *copyPtr)); +static void UpdateStringOfBignum _ANSI_ARGS_((Tcl_Obj *objPtr)); +static int SetBignumFromAny _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Obj* objPtr)); /* * Prototypes for the array hash key methods. @@ -210,8 +211,7 @@ static int CompareObjKeys _ANSI_ARGS_(( static void FreeObjEntry _ANSI_ARGS_(( Tcl_HashEntry *hPtr)); static unsigned int HashObjKey _ANSI_ARGS_(( - Tcl_HashTable *tablePtr, - VOID *keyPtr)); + Tcl_HashTable *tablePtr, VOID *keyPtr)); /* * Prototypes for the CommandName object type. @@ -219,8 +219,7 @@ static unsigned int HashObjKey _ANSI_ARGS_(( static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, Tcl_Obj *copyPtr)); -static void FreeCmdNameInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); +static void FreeCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); @@ -272,7 +271,7 @@ Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ - UpdateStringOfBignum, /* updateStringProc */ + UpdateStringOfBignum, /* updateStringProc */ SetBignumFromAny /* setFromAnyProc */ }; @@ -290,17 +289,17 @@ Tcl_HashKeyType tclObjHashKeyType = { /* * The structure below defines the command name Tcl object type by means of - * procedures that can be invoked by generic object code. Objects of this - * type cache the Command pointer that results from looking up command names - * in the command hashtable. Such objects appear as the zeroth ("command - * name") argument in a Tcl command. + * procedures that can be invoked by generic object code. Objects of this type + * cache the Command pointer that results from looking up command names in the + * command hashtable. Such objects appear as the zeroth ("command name") + * argument in a Tcl command. * * NOTE: the ResolvedCmdName that gets cached is stored in the - * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. - * You might think you could use the simpler otherValuePtr field to - * store the single ResolvedCmdName pointer, but DO NOT DO THIS. It - * seems that some extensions use the second internal pointer field - * of the twoPtrValue field for their own purposes. + * twoPtrValue.ptr1 field, and the twoPtrValue.ptr2 field is unused. You might + * think you could use the simpler otherValuePtr field to store the single + * ResolvedCmdName pointer, but DO NOT DO THIS. It seems that some extensions + * use the second internal pointer field of the twoPtrValue field for their + * own purposes. */ static Tcl_ObjType tclCmdNameType = { @@ -313,38 +312,38 @@ static Tcl_ObjType tclCmdNameType = { /* - * Structure containing a cached pointer to a command that is the result - * of resolving the command's name in some namespace. It is the internal - * representation for a cmdName object. It contains the pointer along - * with some information that is used to check the pointer's validity. + * Structure containing a cached pointer to a command that is the result of + * resolving the command's name in some namespace. It is the internal + * representation for a cmdName object. It contains the pointer along with + * some information that is used to check the pointer's validity. */ typedef struct ResolvedCmdName { Command *cmdPtr; /* A cached Command pointer. */ Namespace *refNsPtr; /* Points to the namespace containing the - * reference (not the namespace that - * contains the referenced command). */ + * reference (not the namespace that contains + * the referenced command). */ long refNsId; /* refNsPtr's unique namespace id. Used to - * verify that refNsPtr is still valid - * (e.g., it's possible that the cmd's - * containing namespace was deleted and a - * new one created at the same address). */ + * verify that refNsPtr is still valid (e.g., + * it's possible that the cmd's containing + * namespace was deleted and a new one created + * at the same address). */ int refNsCmdEpoch; /* Value of the referencing namespace's * cmdRefEpoch when the pointer was cached. * Before using the cached pointer, we check * if the namespace's epoch was incremented; * if so, this cached pointer is invalid. */ int cmdEpoch; /* Value of the command's cmdEpoch when this - * pointer was cached. Before using the - * cached pointer, we check if the cmd's - * epoch was incremented; if so, the cmd was - * renamed, deleted, hidden, or exposed, and - * so the pointer is invalid. */ - int refCount; /* Reference count: 1 for each cmdName - * object that has a pointer to this - * ResolvedCmdName structure as its internal - * rep. This structure can be freed when - * refCount becomes zero. */ + * pointer was cached. Before using the cached + * pointer, we check if the cmd's epoch was + * incremented; if so, the cmd was renamed, + * deleted, hidden, or exposed, and so the + * pointer is invalid. */ + int refCount; /* Reference count: 1 for each cmdName object + * that has a pointer to this ResolvedCmdName + * structure as its internal rep. This + * structure can be freed when refCount + * becomes zero. */ } ResolvedCmdName; @@ -353,16 +352,15 @@ typedef struct ResolvedCmdName { * * TclInitObjectSubsystem -- * - * This procedure is invoked to perform once-only initialization of - * the type table. It also registers the object types defined in - * this file. + * This procedure is invoked to perform once-only initialization of the + * type table. It also registers the object types defined in this file. * * Results: * None. * * Side effects: - * Initializes the table of defined object types "typeTable" with - * builtin object types defined in this file. + * Initializes the table of defined object types "typeTable" with builtin + * object types defined in this file. * *------------------------------------------------------------------------- */ @@ -380,7 +378,7 @@ TclInitObjSubsystem() Tcl_RegisterObjType(&tclEndOffsetType); Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclWideIntType); - Tcl_RegisterObjType( &tclBignumType ); + Tcl_RegisterObjType(&tclBignumType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); @@ -444,25 +442,25 @@ TclFinalizeCompExecEnv() * * Tcl_RegisterObjType -- * - * This procedure is called to register a new Tcl object type - * in the table of all object types supported by Tcl. + * This procedure is called to register a new Tcl object type in the + * table of all object types supported by Tcl. * * Results: * None. * * Side effects: - * The type is registered in the Tcl type table. If there was already - * a type with the same name as in typePtr, it is replaced with the - * new type. + * The type is registered in the Tcl type table. If there was already a + * type with the same name as in typePtr, it is replaced with the new + * type. * *-------------------------------------------------------------- */ void Tcl_RegisterObjType(typePtr) - Tcl_ObjType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ + Tcl_ObjType *typePtr; /* Information about object type; storage must + * be statically allocated (must live + * forever). */ { register Tcl_HashEntry *hPtr; int new; @@ -470,6 +468,7 @@ Tcl_RegisterObjType(typePtr) /* * If there's already an object type with the given name, remove it. */ + Tcl_MutexLock(&tableMutex); hPtr = Tcl_FindHashEntry(&typeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { @@ -493,21 +492,20 @@ Tcl_RegisterObjType(typePtr) * Tcl_AppendAllObjTypes -- * * This procedure appends onto the argument object the name of each - * object type as a list element. This includes the builtin object - * types (e.g. int, list) as well as those added using - * Tcl_NewObj. These names can be used, for example, with - * Tcl_GetObjType to get pointers to the corresponding Tcl_ObjType - * structures. + * object type as a list element. This includes the builtin object types + * (e.g. int, list) as well as those added using Tcl_NewObj. These names + * can be used, for example, with Tcl_GetObjType to get pointers to the + * corresponding Tcl_ObjType structures. * * Results: * The return value is normally TCL_OK; in this case the object - * referenced by objPtr has each type name appended to it. If an - * error occurs, TCL_ERROR is returned and the interpreter's result - * holds an error message. + * referenced by objPtr has each type name appended to it. If an error + * occurs, TCL_ERROR is returned and the interpreter's result holds an + * error message. * * Side effects: - * If necessary, the object referenced by objPtr is converted into - * a list object. + * If necessary, the object referenced by objPtr is converted into a list + * object. * *---------------------------------------------------------------------- */ @@ -516,8 +514,8 @@ int Tcl_AppendAllObjTypes(interp, objPtr) Tcl_Interp *interp; /* Interpreter used for error reporting. */ Tcl_Obj *objPtr; /* Points to the Tcl object onto which the - * name of each registered type is appended - * as a list element. */ + * name of each registered type is appended as + * a list element. */ { register Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -551,9 +549,8 @@ Tcl_AppendAllObjTypes(interp, objPtr) * This procedure looks up an object type by name. * * Results: - * If an object type with name matching "typeName" is found, a pointer - * to its Tcl_ObjType structure is returned; otherwise, NULL is - * returned. + * If an object type with name matching "typeName" is found, a pointer to + * its Tcl_ObjType structure is returned; otherwise, NULL is returned. * * Side effects: * None. @@ -588,10 +585,10 @@ Tcl_GetObjType(typeName) * * Results: * The return value is TCL_OK on success and TCL_ERROR on failure. If - * TCL_ERROR is returned, then the interpreter's result contains an - * error message unless "interp" is NULL. Passing a NULL "interp" - * allows this procedure to be used as a test whether the conversion - * could be done (and in fact was done). + * TCL_ERROR is returned, then the interpreter's result contains an error + * message unless "interp" is NULL. Passing a NULL "interp" allows this + * procedure to be used as a test whether the conversion could be done + * (and in fact was done). * * Side effects: * Any internal representation for the old type is freed. @@ -610,8 +607,8 @@ Tcl_ConvertToType(interp, objPtr, typePtr) } /* - * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal - * form as appropriate for the target type. This frees the old internal + * Use the target type's Tcl_SetFromAnyProc to set "objPtr"s internal form + * as appropriate for the target type. This frees the old internal * representation. */ @@ -627,10 +624,10 @@ Tcl_ConvertToType(interp, objPtr, typePtr) * * TclDbInitNewObj -- * - * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG - * is enabled. This function will initialize the members of a - * Tcl_Obj struct. Initilization would be done inline via the - * TclNewObj macro when compiling without TCL_MEM_DEBUG. + * Called via the TclNewObj or TclDbNewObj macros when TCL_MEM_DEBUG is + * enabled. This function will initialize the members of a Tcl_Obj + * struct. Initilization would be done inline via the TclNewObj macro + * when compiling without TCL_MEM_DEBUG. * * Results: * The Tcl_Obj struct members are initialized. @@ -639,6 +636,7 @@ Tcl_ConvertToType(interp, objPtr, typePtr) * None. *---------------------------------------------------------------------- */ + #ifdef TCL_MEM_DEBUG void TclDbInitNewObj(objPtr) register Tcl_Obj *objPtr; @@ -647,11 +645,13 @@ void TclDbInitNewObj(objPtr) objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; objPtr->typePtr = NULL; -# ifdef TCL_THREADS + +#ifdef TCL_THREADS /* - * Add entry to a thread local map used to check if a Tcl_Obj - * was allocated by the currently executing thread. + * Add entry to a thread local map used to check if a Tcl_Obj was + * allocated by the currently executing thread. */ + if (!TclInExit()) { Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -670,7 +670,7 @@ void TclDbInitNewObj(objPtr) } Tcl_SetHashValue(hPtr, NULL); } -# endif /* TCL_THREADS */ +#endif /* TCL_THREADS */ } #endif /* TCL_MEM_DEBUG */ @@ -682,20 +682,20 @@ void TclDbInitNewObj(objPtr) * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates new Tcl objects that denote * the empty string. These objects have a NULL object type and NULL - * string representation byte pointer. Type managers call this routine - * to allocate new objects that they further initialize. + * string representation byte pointer. Type managers call this routine to + * allocate new objects that they further initialize. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewObj. * * Results: * The result is a newly allocated object that represents the empty - * string. The new object's typePtr is set NULL and its ref count - * is set to 0. + * string. The new object's typePtr is set NULL and its ref count is set + * to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this procedure increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ @@ -717,8 +717,7 @@ Tcl_NewObj() register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclNewObj(objPtr); @@ -733,22 +732,22 @@ Tcl_NewObj() * * This procedure is normally called when debugging: i.e., when * TCL_MEM_DEBUG is defined. It creates new Tcl objects that denote the - * empty string. It is the same as the Tcl_NewObj procedure above - * except that it calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the correct file name and line + * empty string. It is the same as the Tcl_NewObj procedure above except + * that it calls Tcl_DbCkalloc directly with the file name and line + * number from its caller. This simplifies debugging since then the + * [memory active] command will report the correct file name and line * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewObj. * * Results: - * The result is a newly allocated that represents the empty string. - * The new object's typePtr is set NULL and its ref count is set to 0. + * The result is a newly allocated that represents the empty string. The + * new object's typePtr is set NULL and its ref count is set to 0. * * Side effects: - * If compiling with TCL_COMPILE_STATS, this procedure increments - * the global count of allocated objects (tclObjsAlloced). + * If compiling with TCL_COMPILE_STATS, this procedure increments the + * global count of allocated objects (tclObjsAlloced). * *---------------------------------------------------------------------- */ @@ -759,14 +758,13 @@ Tcl_Obj * Tcl_DbNewObj(file, line) register CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - register int line; /* Line number in the source file; used - * for debugging. */ + register int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; /* - * Use the macro defined in tclInt.h - it will use the - * correct allocator. + * Use the macro defined in tclInt.h - it will use the correct allocator. */ TclDbNewObj(objPtr, file, line); @@ -778,8 +776,8 @@ Tcl_Obj * Tcl_DbNewObj(file, line) CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewObj(); } @@ -790,8 +788,8 @@ Tcl_DbNewObj(file, line) * * TclAllocateFreeObjects -- * - * Procedure to allocate a number of free Tcl_Objs. This is done using - * a single ckalloc to reduce the overhead for Tcl_Obj allocation. + * Procedure to allocate a number of free Tcl_Objs. This is done using a + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * @@ -819,8 +817,8 @@ TclAllocateFreeObjects() /* * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated - * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of - * actually freeing the memory. These never do get freed properly. + * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually + * freeing the memory. These never do get freed properly. */ basePtr = (char *) ckalloc(bytesToAlloc); @@ -842,22 +840,21 @@ TclAllocateFreeObjects() * * TclFreeObj -- * - * This procedure frees the memory associated with the argument - * object. It is called by the tcl.h macro Tcl_DecrRefCount when an - * object's ref count is zero. It is only "public" since it must - * be callable by that macro wherever the macro is used. It should not - * be directly called by clients. + * This procedure frees the memory associated with the argument object. + * It is called by the tcl.h macro Tcl_DecrRefCount when an object's ref + * count is zero. It is only "public" since it must be callable by that + * macro wherever the macro is used. It should not be directly called by + * clients. * * Results: * None. * * Side effects: - * Deallocates the storage for the object's Tcl_Obj structure - * after deallocating the string representation and calling the - * type-specific Tcl_FreeInternalRepProc to deallocate the object's - * internal representation. If compiling with TCL_COMPILE_STATS, - * this procedure increments the global count of freed objects - * (tclObjsFreed). + * Deallocates the storage for the object's Tcl_Obj structure after + * deallocating the string representation and calling the type-specific + * Tcl_FreeInternalRepProc to deallocate the object's internal + * representation. If compiling with TCL_COMPILE_STATS, this procedure + * increments the global count of freed objects (tclObjsFreed). * *---------------------------------------------------------------------- */ @@ -868,9 +865,11 @@ TclFreeObj(objPtr) register Tcl_Obj *objPtr; /* The object to be freed. */ { register Tcl_ObjType *typePtr = objPtr->typePtr; + /* * This macro declares a variable, so must come here... */ + ObjInitDeletionContext(context); if (objPtr->refCount < -1) { @@ -922,20 +921,21 @@ TclFreeObj(objPtr) * other objects: it will not cause recursive calls to this function. */ - if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { + if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { ckfree((char *) objPtr->bytes); } TclFreeObjStorage(objPtr); - TclIncrObjsFreed(); + TclIncrObjsFreed(); } else { /* * This macro declares a variable, so must come here... */ + ObjInitDeletionContext(context); - + if (ObjDeletePending(context)) { PushObjToDelete(context, objPtr); - } else { + } else { /* * Note that the contents of the while loop assume that the string * rep has already been freed and we don't want to do anything @@ -943,29 +943,29 @@ TclFreeObj(objPtr) * to unstack the object first since freeing the internal rep can * add further objects to the stack. The code assumes that it is * the first thing in a block; all current usages in the core - * satisfy this. + * satisfy this. */ - - ObjDeletionLock(context); - objPtr->typePtr->freeIntRepProc(objPtr); - ObjDeletionUnlock(context); - - if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { - ckfree((char *) objPtr->bytes); - } - TclFreeObjStorage(objPtr); - TclIncrObjsFreed(); - ObjDeletionLock(context); - while (ObjOnStack(context)) { - Tcl_Obj *objToFree; - PopObjToDelete(context,objToFree); - if ((objToFree->typePtr != NULL) - && (objToFree->typePtr->freeIntRepProc != NULL)) { - objToFree->typePtr->freeIntRepProc(objToFree); - } - TclFreeObjStorage(objToFree); - TclIncrObjsFreed(); - } + + ObjDeletionLock(context); + objPtr->typePtr->freeIntRepProc(objPtr); + ObjDeletionUnlock(context); + + if (objPtr->bytes && (objPtr->bytes != tclEmptyStringRep)) { + ckfree((char *) objPtr->bytes); + } + TclFreeObjStorage(objPtr); + TclIncrObjsFreed(); + ObjDeletionLock(context); + while (ObjOnStack(context)) { + Tcl_Obj *objToFree; + PopObjToDelete(context,objToFree); + if ((objToFree->typePtr != NULL) + && (objToFree->typePtr->freeIntRepProc != NULL)) { + objToFree->typePtr->freeIntRepProc(objToFree); + } + TclFreeObjStorage(objToFree); + TclIncrObjsFreed(); + } ObjDeletionUnlock(context); } } @@ -981,22 +981,22 @@ TclFreeObj(objPtr) * object. * * Results: - * The return value is a pointer to a newly created Tcl_Obj. This - * object has reference count 0 and the same type, if any, as the - * source object objPtr. Also: + * The return value is a pointer to a newly created Tcl_Obj. This object + * has reference count 0 and the same type, if any, as the source object + * objPtr. Also: * 1) If the source object has a valid string rep, we copy it; - * otherwise, the duplicate's string rep is set NULL to mark - * it invalid. + * otherwise, the duplicate's string rep is set NULL to mark it + * invalid. * 2) If the source object has an internal representation (i.e. its - * typePtr is non-NULL), the new object's internal rep is set to - * a copy; otherwise the new internal rep is marked invalid. + * typePtr is non-NULL), the new object's internal rep is set to a + * copy; otherwise the new internal rep is marked invalid. * * Side effects: - * What constitutes "copying" the internal representation depends on - * the type. For example, if the argument object is a list, - * the element objects it points to will not actually be copied but - * will be shared with the duplicate list. That is, the ref counts of - * the element objects will be incremented. + * What constitutes "copying" the internal representation depends on the + * type. For example, if the argument object is a list, the element + * objects it points to will not actually be copied but will be shared + * with the duplicate list. That is, the ref counts of the element + * objects will be incremented. * *---------------------------------------------------------------------- */ @@ -1050,8 +1050,8 @@ Tcl_DuplicateObj(objPtr) char * Tcl_GetString(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be returned. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be returned. */ { if (objPtr->bytes != NULL) { return objPtr->bytes; @@ -1070,16 +1070,16 @@ Tcl_GetString(objPtr) * * Tcl_GetStringFromObj -- * - * Returns the string representation's byte array pointer and length - * for an object. + * Returns the string representation's byte array pointer and length for + * an object. * * Results: - * Returns a pointer to the string representation of objPtr. If - * lengthPtr isn't NULL, the length of the string representation is - * stored at *lengthPtr. The byte array referenced by the returned - * pointer must not be modified by the caller. Furthermore, the - * caller must copy the bytes if they need to retain them since the - * object's string rep can change as a result of other operations. + * Returns a pointer to the string representation of objPtr. If lengthPtr + * isn't NULL, the length of the string representation is stored at + * *lengthPtr. The byte array referenced by the returned pointer must not + * be modified by the caller. Furthermore, the caller must copy the bytes + * if they need to retain them since the object's string rep can change + * as a result of other operations. * * Side effects: * May call the object's updateStringProc to update the string @@ -1122,16 +1122,16 @@ Tcl_GetStringFromObj(objPtr, lengthPtr) * None. * * Side effects: - * Deallocates the storage for any old string representation, then - * sets the string representation NULL to mark it invalid. + * Deallocates the storage for any old string representation, then sets + * the string representation NULL to mark it invalid. * *---------------------------------------------------------------------- */ void Tcl_InvalidateStringRep(objPtr) - register Tcl_Obj *objPtr; /* Object whose string rep byte pointer - * should be freed. */ + register Tcl_Obj *objPtr; /* Object whose string rep byte pointer should + * be freed. */ { TclInvalidateStringRep(objPtr); } @@ -1144,15 +1144,15 @@ Tcl_InvalidateStringRep(objPtr) * * This procedure is normally called when not debugging: i.e., when * TCL_MEM_DEBUG is not defined. It creates a new boolean object and - * initializes it from the argument boolean value. A nonzero - * "boolValue" is coerced to 1. + * initializes it from the argument boolean value. A nonzero "boolValue" + * is coerced to 1. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewBooleanObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1193,15 +1193,15 @@ Tcl_NewBooleanObj(boolValue) * same as the Tcl_NewBooleanObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewBooleanObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1216,8 +1216,8 @@ Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; @@ -1236,8 +1236,8 @@ Tcl_DbNewBooleanObj(boolValue, file, line) register int boolValue; /* Boolean used to initialize new object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewBooleanObj(boolValue); } @@ -1255,8 +1255,8 @@ Tcl_DbNewBooleanObj(boolValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ @@ -1301,14 +1301,13 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) double d; long l; - /* - * The flow through this routine is "optimized" to avoid the - * generation of string rep. for "pure" numeric values. However, - * once the string rep is generated it's fairly inefficient at - * determining a string is *not* a valid boolean. It has to - * scan the string as many as four times (ruling out "double", - * "long", "wideint", and "boolean" in turn) to figure out that - * an invalid boolean value is stored in objPtr->bytes. + /* + * The flow through this routine is "optimized" to avoid the generation of + * string rep. for "pure" numeric values. However, once the string rep is + * generated it's fairly inefficient at determining a string is *not* a + * valid boolean. It has to scan the string as many as four times (ruling + * out "double", "long", "wideint", and "boolean" in turn) to figure out + * that an invalid boolean value is stored in objPtr->bytes. */ if (objPtr->typePtr == &tclIntType) { @@ -1325,34 +1324,37 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) } /* - * Caution: Don't be tempted to check directly for the - * "double" Tcl_ObjType and then compare the intrep to 0.0. - * This isn't reliable because a "double" Tcl_ObjType can - * hold the NaN value. Use the API Tcl_GetDoubleFromObj, - * which does the checking for us. + * Caution: Don't be tempted to check directly for the "double" + * Tcl_ObjType and then compare the intrep to 0.0. This isn't reliable + * because a "double" Tcl_ObjType can hold the NaN value. Use the API + * Tcl_GetDoubleFromObj, which does the checking for us. */ - /* - * The following call retrieves a numeric value without - * generating the string rep of a double. + /* + * The following call retrieves a numeric value without generating the + * string rep of a double. */ + if (Tcl_GetDoubleFromObj(NULL, objPtr, &d) == TCL_OK) { *boolPtr = (d != 0.0); - /* Tcl_GetDoubleFromObj() will succeed on the strings "0" - * and "1", but we'd rather keep those values around as - * a better objType for boolean value. Following call - * will shimmer appropriately. + /* + * Tcl_GetDoubleFromObj() will succeed on the strings "0" and "1", but + * we'd rather keep those values around as a better objType for + * boolean value. Following call will shimmer appropriately. */ + if (objPtr->bytes != NULL) { - SetBooleanFromAny(NULL, objPtr); + SetBooleanFromAny(NULL, objPtr); } return TCL_OK; } + /* - * Value didn't already have a numeric intrep, but perhaps we can - * generate one. Try a long value first... + * Value didn't already have a numeric intrep, but perhaps we can generate + * one. Try a long value first... */ + if (Tcl_GetLongFromObj(NULL, objPtr, &l) == TCL_OK) { *boolPtr = (l != 0); return TCL_OK; @@ -1360,20 +1362,24 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) #ifndef TCL_WIDE_INT_IS_LONG else { Tcl_WideInt w; + /* * ...then a wide. Check in that order so that we don't promote * anything to wide unnecessarily. */ + if (Tcl_GetWideIntFromObj(NULL, objPtr, &w) == TCL_OK) { *boolPtr = (w != 0); return TCL_OK; } } #endif + /* - * Finally, check for the string values like "yes" - * and generate error message for non-boolean values. + * Finally, check for the string values like "yes" and generate error + * message for non-boolean values. */ + if (SetBooleanFromAny(interp, objPtr) == TCL_OK) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; @@ -1395,8 +1401,8 @@ Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) * unless "interp" is NULL. * * Side effects: - * If no error occurs, an integer 1 or 0 is stored as "objPtr"s - * internal representation and the type of "objPtr" is set to boolean. + * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal + * representation and the type of "objPtr" is set to boolean. * *---------------------------------------------------------------------- */ @@ -1410,9 +1416,9 @@ SetBooleanFromAny(interp, objPtr) int i, newBool, length; /* - * For some "pure" numeric Tcl_ObjTypes (no string rep), we can - * determine whether a boolean conversion is possible without - * generating the string rep. + * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine + * whether a boolean conversion is possible without generating the string + * rep. */ if (objPtr->bytes == NULL) { @@ -1421,15 +1427,15 @@ SetBooleanFromAny(interp, objPtr) } if (objPtr->typePtr == &tclIntType) { switch (objPtr->internalRep.longValue) { - case 0L: case 1L: - return TCL_OK; + case 0L: case 1L: + return TCL_OK; } goto badBoolean; } if (objPtr->typePtr == &tclWideIntType) { Tcl_WideInt w = objPtr->internalRep.wideValue; - if ( w == 0 || w == 1 ) { - newBool = (int)w; + if (w == 0 || w == 1) { + newBool = (int) w; goto numericBoolean; } else { goto badBoolean; @@ -1438,8 +1444,8 @@ SetBooleanFromAny(interp, objPtr) } /* - * Parse the string as a boolean. We use an implementation here - * that doesn't report errors in interp if interp is NULL. + * Parse the string as a boolean. We use an implementation here that + * doesn't report errors in interp if interp is NULL. */ str = Tcl_GetStringFromObj(objPtr, &length); @@ -1464,21 +1470,23 @@ SetBooleanFromAny(interp, objPtr) } /* - * Force to lower case for case-insensitive detection. - * Filter out known invalid characters at the same time. + * Force to lower case for case-insensitive detection. Filter out known + * invalid characters at the same time. */ for (i=0; i < length; i++) { char c = str[i]; switch (c) { - case 'A': case 'E': case 'F': case 'L': case 'N': - case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': - lowerCase[i] = c + (char) ('a' - 'A'); break; - case 'a': case 'e': case 'f': case 'l': case 'n': - case 'o': case 'r': case 's': case 't': case 'u': case 'y': - lowerCase[i] = c; break; - default: - goto badBoolean; + case 'A': case 'E': case 'F': case 'L': case 'N': + case 'O': case 'R': case 'S': case 'T': case 'U': case 'Y': + lowerCase[i] = c + (char) ('a' - 'A'); + break; + case 'a': case 'e': case 'f': case 'l': case 'n': + case 'o': case 'r': case 's': case 't': case 'u': case 'y': + lowerCase[i] = c; + break; + default: + goto badBoolean; } } lowerCase[length] = 0; @@ -1527,18 +1535,18 @@ SetBooleanFromAny(interp, objPtr) } /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ - goodBoolean: + goodBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; - badBoolean: + badBoolean: if (interp != NULL) { Tcl_Obj *msg = Tcl_NewStringObj("expected boolean value but got \"", -1); @@ -1549,7 +1557,7 @@ SetBooleanFromAny(interp, objPtr) } return TCL_ERROR; - numericBoolean: + numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclIntType; @@ -1561,16 +1569,16 @@ SetBooleanFromAny(interp, objPtr) * * UpdateStringOfBoolean -- * - * Update the string representation for a boolean object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a boolean object. Note: This + * procedure does not free an existing old string rep so storage will be + * lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the boolean-to-string conversion. + * The object's string is set to a valid string that results from the + * boolean-to-string conversion. * *---------------------------------------------------------------------- */ @@ -1596,8 +1604,8 @@ UpdateStringOfBoolean(objPtr) * TCL_MEM_DEBUG is not defined. It creates a new double object and * initializes it from the argument double value. * - * When TCL_MEM_DEBUG is defined, this procedure just returns the - * result of calling the debugging version Tcl_DbNewDoubleObj. + * When TCL_MEM_DEBUG is defined, this procedure just returns the result + * of calling the debugging version Tcl_DbNewDoubleObj. * * Results: * The newly created object is returned. This object will have an @@ -1642,15 +1650,15 @@ Tcl_NewDoubleObj(dblValue) * same as the Tcl_NewDoubleObj procedure above except that it calls * Tcl_DbCkalloc directly with the file name and line number from its * caller. This simplifies debugging since then the [memory active] - * command will report the correct file name and line number when + * command will report the correct file name and line number when * reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewDoubleObj. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1665,8 +1673,8 @@ Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; @@ -1685,8 +1693,8 @@ Tcl_DbNewDoubleObj(dblValue, file, line) register double dblValue; /* Double used to initialize the object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewDoubleObj(dblValue); } @@ -1704,8 +1712,8 @@ Tcl_DbNewDoubleObj(dblValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ @@ -1727,9 +1735,8 @@ Tcl_SetDoubleObj(objPtr, dblValue) * * Tcl_GetDoubleFromObj -- * - * Attempt to return a double from the Tcl object "objPtr". If the - * object is not already a double, an attempt will be made to convert - * it to one. + * Attempt to return a double from the Tcl object "objPtr". If the object + * is not already a double, an attempt will be made to convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -1737,8 +1744,8 @@ Tcl_SetDoubleObj(objPtr, dblValue) * result unless "interp" is NULL. * * Side effects: - * If the object is not already a double, the conversion will free - * any old internal representation. + * If the object is not already a double, the conversion will free any + * old internal representation. * *---------------------------------------------------------------------- */ @@ -1759,16 +1766,14 @@ Tcl_GetDoubleFromObj(interp, objPtr, dblPtr) return TCL_OK; } else if (objPtr->typePtr != &tclDoubleType) { result = SetDoubleFromAny(interp, objPtr); - if ( result != TCL_OK ) { + if (result != TCL_OK) { return TCL_ERROR; } } - if ( IS_NAN( objPtr->internalRep.doubleValue ) ) { - if ( interp != NULL ) { - Tcl_SetObjResult - ( interp, - Tcl_NewStringObj( "floating point value is Not a Number", - -1 ) ); + if (IS_NAN(objPtr->internalRep.doubleValue)) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "floating point value is Not a Number", -1)); } return TCL_ERROR; } @@ -1868,8 +1873,8 @@ SetDoubleFromAny(interp, objPtr) * * UpdateStringOfDouble -- * - * Update the string representation for a double-precision floating - * point object. This must obey the current tcl_precision value for + * Update the string representation for a double-precision floating point + * object. This must obey the current tcl_precision value for * double-to-string conversions. Note: This procedure does not free an * existing old string rep so storage will be lost if this has not * already been done. @@ -1878,8 +1883,8 @@ SetDoubleFromAny(interp, objPtr) * None. * * Side effects: - * The object's string is set to a valid string that results from - * the double-to-string conversion. + * The object's string is set to a valid string that results from the + * double-to-string conversion. * *---------------------------------------------------------------------- */ @@ -1911,18 +1916,18 @@ UpdateStringOfDouble(objPtr) * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewIntObj result in a call to one of the two - * Tcl_NewIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewIntObj implementations below. We provide two implementations so + * that the Tcl core can be compiled to do memory debugging of the core + * even if a client does not request it for itself. * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -1965,8 +1970,8 @@ Tcl_NewIntObj(intValue) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ @@ -1993,18 +1998,18 @@ Tcl_SetIntObj(objPtr, intValue) * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: * The return value is a standard Tcl object result. If an error occurs - * during conversion or if the long integer held by the object - * can not be represented by an int, an error message is left in - * the interpreter's result unless "interp" is NULL. + * during conversion or if the long integer held by the object can not be + * represented by an int, an error message is left in the interpreter's + * result unless "interp" is NULL. * * Side effects: - * If the object is not already an int, the conversion will free - * any old internal representation. + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ @@ -2018,8 +2023,9 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) int result; Tcl_WideInt w = 0; - /* If the object isn't already an integer of any width, try to - * convert it to one. + /* + * If the object isn't already an integer of any width, try to convert it + * to one. */ if (objPtr->typePtr != &tclIntType && objPtr->typePtr != &tclWideIntType) { @@ -2029,7 +2035,9 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) } } - /* Object should now be either int or wide. Get its value. */ + /* + * Object should now be either int or wide. Get its value. + */ #ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { @@ -2058,13 +2066,13 @@ Tcl_GetIntFromObj(interp, objPtr, intPtr) * * SetIntFromAny -- * - * Attempts to force the internal representation for a Tcl object - * to tclIntType, specifically. + * Attempts to force the internal representation for a Tcl object to + * tclIntType, specifically. * * Results: - * The return value is a standard object Tcl result. If an - * error occurs during conversion, an error message is left in - * the interpreter's result unless "interp" is NULL. + * The return value is a standard object Tcl result. If an error occurs + * during conversion, an error message is left in the interpreter's + * result unless "interp" is NULL. * *---------------------------------------------------------------------- */ @@ -2132,9 +2140,9 @@ SetIntOrWideFromAny(interp, objPtr) * Now parse "objPtr"s string as an int. We use an implementation here * that doesn't report errors in interp if interp is NULL. Note: use * strtoul instead of strtol for integer conversions to allow full-size - * unsigned numbers. We parse the leading space and sign ourselves so - * we can tell the difference between apparently positive and negative - * values. + * unsigned numbers. We parse the leading space and sign ourselves so we + * can tell the difference between apparently positive and negative + * values. */ errno = 0; @@ -2148,7 +2156,7 @@ SetIntOrWideFromAny(interp, objPtr) p++; } if (!isdigit(UCHAR(*p))) { - badInteger: + badInteger: if (interp != NULL) { Tcl_Obj *msg = Tcl_NewStringObj("expected integer but got \"", -1); @@ -2195,8 +2203,8 @@ SetIntOrWideFromAny(interp, objPtr) TclFreeIntRep(objPtr); #ifndef TCL_WIDE_INT_IS_LONG /* - * If the resulting integer will exceed the range of a long, - * put it into a wide instead. (Tcl Bug #868489) + * If the resulting integer will exceed the range of a long, put it into a + * wide instead. (Tcl Bug #868489) */ if ((isNegative && newLong > (unsigned long) (LONG_MAX) + 1) @@ -2219,16 +2227,16 @@ SetIntOrWideFromAny(interp, objPtr) * * UpdateStringOfInt -- * - * Update the string representation for an integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for an integer object. Note: This + * procedure does not free an existing old string rep so storage will be + * lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the int-to-string conversion. + * The object's string is set to a valid string that results from the + * int-to-string conversion. * *---------------------------------------------------------------------- */ @@ -2253,8 +2261,8 @@ UpdateStringOfInt(objPtr) * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewLongObj to create a new long integer object end up calling - * the debugging procedure Tcl_DbNewLongObj instead. + * Tcl_NewLongObj to create a new long integer object end up calling the + * debugging procedure Tcl_DbNewLongObj instead. * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewLongObj result in a call to one of the two @@ -2264,12 +2272,12 @@ UpdateStringOfInt(objPtr) * * Integer and long integer objects share the same "integer" type * implementation. We store all integers as longs and Tcl_GetIntFromObj - * checks whether the current value of the long can be represented by - * an int. + * checks whether the current value of the long can be represented by an + * int. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -2308,26 +2316,25 @@ Tcl_NewLongObj(longValue) * Tcl_DbNewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or - * long integer objects end up calling the debugging procedure - * Tcl_DbNewLongObj instead. We provide two implementations of - * Tcl_DbNewLongObj so that whether the Tcl core is compiled to do - * memory debugging of the core is independent of whether a client - * requests debugging for itself. - * - * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewLongObj calls Tcl_DbCkalloc directly with the file name and - * line number from its caller. This simplifies debugging since then - * the [memory active] command will report the caller's file name and - * line number when reporting objects that haven't been freed. + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer + * objects end up calling the debugging procedure Tcl_DbNewLongObj + * instead. We provide two implementations of Tcl_DbNewLongObj so that + * whether the Tcl core is compiled to do memory debugging of the core is + * independent of whether a client requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj + * calls Tcl_DbCkalloc directly with the file name and line number from + * its caller. This simplifies debugging since then the [memory active] + * command will report the caller's file name and line number when + * reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewLongObj. * * Results: - * The newly created long integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created long integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. @@ -2339,12 +2346,12 @@ Tcl_NewLongObj(longValue) Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ + register long longValue; /* Long integer used to initialize the new + * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { register Tcl_Obj *objPtr; @@ -2360,12 +2367,12 @@ Tcl_DbNewLongObj(longValue, file, line) Tcl_Obj * Tcl_DbNewLongObj(longValue, file, line) - register long longValue; /* Long integer used to initialize the - * new object. */ + register long longValue; /* Long integer used to initialize the new + * object. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { return Tcl_NewLongObj(longValue); } @@ -2383,8 +2390,8 @@ Tcl_DbNewLongObj(longValue, file, line) * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ @@ -2407,8 +2414,8 @@ Tcl_SetLongObj(objPtr, longValue) * * Tcl_GetLongFromObj -- * - * Attempt to return an long integer from the Tcl object "objPtr". If - * the object is not already an int object, an attempt will be made to + * Attempt to return an long integer from the Tcl object "objPtr". If the + * object is not already an int object, an attempt will be made to * convert it to one. * * Results: @@ -2442,13 +2449,14 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr) #ifndef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclWideIntType) { /* - * If the object is already a wide integer, don't convert it. - * This code allows for any integer in the range -ULONG_MAX to - * ULONG_MAX to be converted to a long, ignoring overflow. - * The rule preserves existing semantics for conversion of - * integers on input, but avoids inadvertent demotion of - * wide integers to 32-bit ones in the internal rep. + * If the object is already a wide integer, don't convert it. This + * code allows for any integer in the range -ULONG_MAX to ULONG_MAX to + * be converted to a long, ignoring overflow. The rule preserves + * existing semantics for conversion of integers on input, but avoids + * inadvertent demotion of wide integers to 32-bit ones in the + * internal rep. */ + Tcl_WideInt w = objPtr->internalRep.wideValue; if (w >= -(Tcl_WideInt)(ULONG_MAX) && w <= (Tcl_WideInt)(ULONG_MAX)) { @@ -2570,16 +2578,16 @@ SetWideIntFromAny(interp, objPtr) * * UpdateStringOfWideInt -- * - * Update the string representation for a wide integer object. - * Note: This procedure does not free an existing old string rep - * so storage will be lost if this has not already been done. + * Update the string representation for a wide integer object. Note: + * This procedure does not free an existing old string rep so storage + * will be lost if this has not already been done. * * Results: * None. * * Side effects: - * The object's string is set to a valid string that results from - * the wideInt-to-string conversion. + * The object's string is set to a valid string that results from the + * wideInt-to-string conversion. * *---------------------------------------------------------------------- */ @@ -2594,11 +2602,12 @@ UpdateStringOfWideInt(objPtr) register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; /* - * Note that sprintf will generate a compiler warning under - * Mingw claiming %I64 is an unknown format specifier. - * Just ignore this warning. We can't use %L as the format - * specifier since that gets printed as a 32 bit value. + * Note that sprintf will generate a compiler warning under Mingw claiming + * %I64 is an unknown format specifier. Just ignore this warning. We can't + * use %L as the format specifier since that gets printed as a 32 bit + * value. */ + sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); len = strlen(buffer); objPtr->bytes = ckalloc((unsigned) len + 1); @@ -2618,13 +2627,13 @@ UpdateStringOfWideInt(objPtr) * * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, * calls to Tcl_NewWideIntObj result in a call to one of the two - * Tcl_NewWideIntObj implementations below. We provide two implementations - * so that the Tcl core can be compiled to do memory debugging of the - * core even if a client does not request it for itself. + * Tcl_NewWideIntObj implementations below. We provide two + * implementations so that the Tcl core can be compiled to do memory + * debugging of the core even if a client does not request it for itself. * * Results: - * The newly created object is returned. This object will have an - * invalid string representation. The returned object has ref count 0. + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * * Side effects: * None. @@ -2663,27 +2672,25 @@ Tcl_NewWideIntObj(wideValue) * Tcl_DbNewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to - * Tcl_NewWideIntObj to create new wide integer end up calling - * the debugging procedure Tcl_DbNewWideIntObj instead. We - * provide two implementations of Tcl_DbNewWideIntObj so that - * whether the Tcl core is compiled to do memory debugging of the - * core is independent of whether a client requests debugging for - * itself. + * Tcl_NewWideIntObj to create new wide integer end up calling the + * debugging procedure Tcl_DbNewWideIntObj instead. We provide two + * implementations of Tcl_DbNewWideIntObj so that whether the Tcl core is + * compiled to do memory debugging of the core is independent of whether + * a client requests debugging for itself. * * When the core is compiled with TCL_MEM_DEBUG defined, - * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file - * name and line number from its caller. This simplifies - * debugging since then the checkmem command will report the - * caller's file name and line number when reporting objects that - * haven't been freed. + * Tcl_DbNewWideIntObj calls Tcl_DbCkalloc directly with the file name + * and line number from its caller. This simplifies debugging since then + * the checkmem command will report the caller's file name and line + * number when reporting objects that haven't been freed. * * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, * this procedure just returns the result of calling Tcl_NewWideIntObj. * * Results: - * The newly created wide integer object is returned. This object - * will have an invalid string representation. The returned object has - * ref count 0. + * The newly created wide integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. * * Side effects: * Allocates memory. @@ -2695,10 +2702,10 @@ Tcl_NewWideIntObj(wideValue) Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Wide integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for + register Tcl_WideInt wideValue; /* Wide integer used to initialize the + * new object. */ + CONST char *file; /* The name of the source file calling + * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ @@ -2717,10 +2724,10 @@ Tcl_DbNewWideIntObj(wideValue, file, line) Tcl_Obj * Tcl_DbNewWideIntObj(wideValue, file, line) - register Tcl_WideInt wideValue; /* Long integer used to initialize - * the new object. */ - CONST char *file; /* The name of the source file - * calling this procedure; used for + register Tcl_WideInt wideValue; /* Long integer used to initialize the + * new object. */ + CONST char *file; /* The name of the source file calling + * this procedure; used for * debugging. */ int line; /* Line number in the source file; * used for debugging. */ @@ -2734,15 +2741,15 @@ Tcl_DbNewWideIntObj(wideValue, file, line) * * Tcl_SetWideIntObj -- * - * Modify an object to be a wide integer object and to have the - * specified wide integer value. + * Modify an object to be a wide integer object and to have the specified + * wide integer value. * * Results: * None. * * Side effects: - * The object's old string rep, if any, is freed. Also, any old - * internal rep is freed. + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. * *---------------------------------------------------------------------- */ @@ -2765,9 +2772,9 @@ Tcl_SetWideIntObj(objPtr, wideValue) * * Tcl_GetWideIntFromObj -- * - * Attempt to return a wide integer from the Tcl object "objPtr". If - * the object is not already a wide int object, an attempt will be made - * to convert it to one. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a wide int object, an attempt will be made to + * convert it to one. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -2814,11 +2821,12 @@ Tcl_GetWideIntFromObj(interp, objPtr, wideIntPtr) */ static void -FreeBignum( Tcl_Obj* objPtr ) +FreeBignum(Tcl_Obj *objPtr) { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM( objPtr, toFree ); - mp_clear( &toFree ); + + UNPACK_BIGNUM(objPtr, toFree); + mp_clear(&toFree); } /* @@ -2838,18 +2846,19 @@ FreeBignum( Tcl_Obj* objPtr ) */ static void -DupBignum( srcPtr, copyPtr ) +DupBignum(srcPtr, copyPtr) Tcl_Obj* srcPtr; Tcl_Obj* copyPtr; { mp_int bignumVal; mp_int bignumCopy; + copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM( srcPtr, bignumVal ); - if ( mp_init_copy( &bignumCopy, &bignumVal ) != MP_OKAY ) { - Tcl_Panic( "initialization failure in DupBignum" ); + UNPACK_BIGNUM(srcPtr, bignumVal); + if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { + Tcl_Panic("initialization failure in DupBignum"); } - PACK_BIGNUM( bignumVal, copyPtr ); + PACK_BIGNUM(bignumVal, copyPtr); } /* @@ -2857,12 +2866,12 @@ DupBignum( srcPtr, copyPtr ) * * SetBignumFromAny -- * - * This procedure interprets a Tcl_Obj as a bignum and sets - * the internal representation accordingly. + * This procedure interprets a Tcl_Obj as a bignum and sets the internal + * representation accordingly. * * Results: - * Returns a standard Tcl status. If conversion fails, an - * error message is left in the interpreter result. + * Returns a standard Tcl status. If conversion fails, an error message + * is left in the interpreter result. * * Side effects: * The bignum internal representation is packed into the object. @@ -2871,7 +2880,7 @@ DupBignum( srcPtr, copyPtr ) */ static int -SetBignumFromAny( interp, objPtr ) +SetBignumFromAny(interp, objPtr) Tcl_Interp* interp; Tcl_Obj* objPtr; { @@ -2883,42 +2892,42 @@ SetBignumFromAny( interp, objPtr ) int status; mp_int bignumVal; - if ( objPtr->typePtr == &tclIntType ) { + if (objPtr->typePtr == &tclIntType) { /* - * If the number already contains an integer, simply widen it to - * a bignum. + * If the number already contains an integer, simply widen it to a + * bignum. */ - - TclBNInitBignumFromLong( &bignumVal, objPtr->internalRep.longValue ); + + TclBNInitBignumFromLong(&bignumVal, objPtr->internalRep.longValue); } else { - /* - * The number doesn't contain an integer. Convert its string rep - * to a bignum, handling 0XXX and 0xXXX notation + /* + * The number doesn't contain an integer. Convert its string rep to a + * bignum, handling 0XXX and 0xXXX notation */ - stringVal = Tcl_GetStringFromObj( objPtr, &length ); + stringVal = Tcl_GetStringFromObj(objPtr, &length); p = stringVal; - + /* * Pull off the signum */ - - if ( *p == '+' ) { + + if (*p == '+') { ++p; - } else if ( *p == '-' ) { + } else if (*p == '-') { ++p; signum = MP_NEG; } - + /* * Handle octal and hexadecimal */ - - if ( *p == '0' ) { + + if (*p == '0') { ++p; - if ( *p == 'x' || *p == 'X' ) { + if (*p == 'x' || *p == 'X') { ++p; radix = 16; } else { @@ -2926,53 +2935,50 @@ SetBignumFromAny( interp, objPtr ) radix = 8; } } - + /* Convert the value */ - - if ( mp_init( &bignumVal ) != MP_OKAY ) { - Tcl_Panic( "initialization failure in SetBignumFromAny" ); + + if (mp_init(&bignumVal) != MP_OKAY) { + Tcl_Panic("initialization failure in SetBignumFromAny"); } - status = mp_read_radix( &bignumVal, p, radix ); - switch ( status ) { - case MP_MEM: - Tcl_Panic( "out of memory in SetBignumFromAny" ); - case MP_OKAY: - break; - default: - { - if ( interp != NULL ) { - Tcl_Obj* msg - = Tcl_NewStringObj( "expected integer but got \"", - -1 ); - TclAppendLimitedToObj( msg, stringVal, length, 50, "" ); - Tcl_AppendToObj( msg, "\"", -1 ); - Tcl_SetObjResult( interp, msg ); - TclCheckBadOctal( interp, stringVal ); - } - mp_clear( &bignumVal ); - return TCL_ERROR; + status = mp_read_radix(&bignumVal, p, radix); + switch (status) { + case MP_MEM: + Tcl_Panic("out of memory in SetBignumFromAny"); + case MP_OKAY: + break; + default: + if (interp != NULL) { + Tcl_Obj* msg = Tcl_NewStringObj( + "expected integer but got \"", -1); + TclAppendLimitedToObj(msg, stringVal, length, 50, ""); + Tcl_AppendToObj(msg, "\"", -1); + Tcl_SetObjResult(interp, msg); + TclCheckBadOctal(interp, stringVal); } + mp_clear(&bignumVal); + return TCL_ERROR; } - + /* Conversion to bignum succeeded. Make sure that everything fits. */ - - if ( bignumVal.alloc > 0x7fff ) { - Tcl_Obj* msg - = Tcl_NewStringObj( "integer value too large to represent", -1 ); - Tcl_SetObjResult( interp, msg ); - mp_clear( &bignumVal ); + + if (bignumVal.alloc > 0x7fff) { + Tcl_Obj* msg = + Tcl_NewStringObj("integer value too large to represent",-1); + Tcl_SetObjResult(interp, msg); + mp_clear(&bignumVal); return TCL_ERROR; } } - - /* - * Conversion succeeded. Clean up the old internal rep and - * store the new one. + + /* + * Conversion succeeded. Clean up the old internal rep and store the new + * one. */ - - TclFreeIntRep( objPtr ); + + TclFreeIntRep(objPtr); bignumVal.sign = signum; - PACK_BIGNUM( bignumVal, objPtr ); + PACK_BIGNUM(bignumVal, objPtr); objPtr->typePtr = &tclBignumType; return TCL_OK; } @@ -2982,8 +2988,7 @@ SetBignumFromAny( interp, objPtr ) * * UpdateStringOfBignum -- * - * This procedure updates the string representation of a bignum - * object. + * This procedure updates the string representation of a bignum object. * * Results: * None. @@ -2992,27 +2997,27 @@ SetBignumFromAny( interp, objPtr ) * The object's string is set to whatever results from the bignum- * to-string conversion. * - * The object's existing string representation is NOT freed; memory - * will leak if the string rep is still valid at the time this procedure - * is called. + * The object's existing string representation is NOT freed; memory will leak + * if the string rep is still valid at the time this procedure is called. */ static void -UpdateStringOfBignum( Tcl_Obj* objPtr ) +UpdateStringOfBignum(Tcl_Obj* objPtr) { mp_int bignumVal; int size; int status; char* stringVal; - UNPACK_BIGNUM( objPtr, bignumVal ); - status = mp_radix_size( &bignumVal, 10, &size ); - if ( status != MP_OKAY ) { - Tcl_Panic( "radix size failure in UpdateStringOfBignum" ); + + UNPACK_BIGNUM(objPtr, bignumVal); + status = mp_radix_size(&bignumVal, 10, &size); + if (status != MP_OKAY) { + Tcl_Panic("radix size failure in UpdateStringOfBignum"); } - stringVal = Tcl_Alloc( (size_t) size ); - status = mp_toradix_n( &bignumVal, stringVal, 10, size ); - if ( status != MP_OKAY ) { - Tcl_Panic( "conversion failure in UpdateStringOfBignum" ); + stringVal = Tcl_Alloc((size_t) size); + status = mp_toradix_n(&bignumVal, stringVal, 10, size); + if (status != MP_OKAY) { + Tcl_Panic("conversion failure in UpdateStringOfBignum"); } objPtr->bytes = stringVal; objPtr->length = size - 1; /* size includes a trailing null byte */ @@ -3029,8 +3034,7 @@ UpdateStringOfBignum( Tcl_Obj* objPtr ) * Returns the newly created object. * * Side effects: - * The bignum value is cleared, since ownership has transferred - * to Tcl. + * The bignum value is cleared, since ownership has transferred to Tcl. * *---------------------------------------------------------------------- */ @@ -3038,23 +3042,24 @@ UpdateStringOfBignum( Tcl_Obj* objPtr ) #ifdef TCL_MEM_DEBUG #undef Tcl_NewBignumObj Tcl_Obj* -Tcl_NewBignumObj( mp_int* bignumValue ) +Tcl_NewBignumObj(mp_int* bignumValue) { - return Tcl_DbNewBignumObj( bignumValue, "unknown", 0 ); + return Tcl_DbNewBignumObj(bignumValue, "unknown", 0); } #else Tcl_Obj * -Tcl_NewBignumObj( mp_int* bignumValue ) +Tcl_NewBignumObj(mp_int* bignumValue) { Tcl_Obj* objPtr; - TclNewObj( objPtr ); - PACK_BIGNUM( *bignumValue, objPtr ); + + TclNewObj(objPtr); + PACK_BIGNUM(*bignumValue, objPtr); objPtr->typePtr=&tclBignumType; objPtr->bytes = NULL; /* Clear with mp_init; mp_clear would overwrite the digit array. */ - mp_init( bignumValue ); + mp_init(bignumValue); return objPtr; } @@ -3073,34 +3078,34 @@ Tcl_NewBignumObj( mp_int* bignumValue ) * Returns the newly created object. * * Side effects: - * The bignum value is cleared, since ownership has transferred - * to Tcl. + * The bignum value is cleared, since ownership has transferred to Tcl. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj* -Tcl_DbNewBignumObj( mp_int* bignumValue, CONST char* file, int line ) +Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) { Tcl_Obj* objPtr; - TclDbNewObj( objPtr, file, line ); + + TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - PACK_BIGNUM( *bignumValue, objPtr ); - objPtr->typePtr=&tclBignumType; + PACK_BIGNUM(*bignumValue, objPtr); + objPtr->typePtr = &tclBignumType; objPtr->bytes = NULL; /* Clear with mp_init; mp_clear would overwrite the digit array. */ - mp_init( bignumValue ); + mp_init(bignumValue); return objPtr; } #else Tcl_Obj* -Tcl_DbNewBignumObj( mp_int* bignumValue, CONST char* file, int line ) +Tcl_DbNewBignumObj(mp_int* bignumValue, CONST char* file, int line) { - return Tcl_NewBignumObj( bignumValue ); + return Tcl_NewBignumObj(bignumValue); } #endif @@ -3116,35 +3121,34 @@ Tcl_DbNewBignumObj( mp_int* bignumValue, CONST char* file, int line ) * Returns TCL_OK if the conversion is successful, TCL_ERROR otherwise. * * Side effects: - * A copy of bignum is stored in *bignumValue, which is expected - * to be uninitialized or cleared. If conversion fails, an - * the 'interp' argument is not NULL, an error message is stored - * in the interpreter result. + * A copy of bignum is stored in *bignumValue, which is expected to be + * uninitialized or cleared. If conversion fails, an the 'interp' + * argument is not NULL, an error message is stored in the interpreter + * result. * - * It is expected that the caller will NOT have invoked mp_init on the - * bignum value before passing it in. The raw value of the object is - * returned, and Tcl owns that memory, so the caller should NOT invoke - * mp_clear afterwards. + * It is expected that the caller will NOT have invoked mp_init on the + * bignum value before passing it in. The raw value of the object is + * returned, and Tcl owns that memory, so the caller should NOT invoke + * mp_clear afterwards. * *---------------------------------------------------------------------- */ int -Tcl_GetBignumFromObj( Tcl_Interp* interp, - /* Tcl interpreter for error reporting */ - Tcl_Obj* objPtr, - /* Object to read */ - mp_int* bignumValue ) - /* Returned bignum value. */ +Tcl_GetBignumFromObj( + Tcl_Interp* interp, /* Tcl interpreter for error reporting */ + Tcl_Obj* objPtr, /* Object to read */ + mp_int* bignumValue) /* Returned bignum value. */ { mp_int temp; - if ( objPtr -> typePtr != &tclBignumType ) { - if ( SetBignumFromAny( interp, objPtr ) != TCL_OK ) { + + if (objPtr->typePtr != &tclBignumType) { + if (SetBignumFromAny(interp, objPtr) != TCL_OK) { return TCL_ERROR; } } - UNPACK_BIGNUM( objPtr, temp ); - mp_init_copy( bignumValue, &temp ); + UNPACK_BIGNUM(objPtr, temp); + mp_init_copy(bignumValue, &temp); return TCL_OK; } @@ -3159,29 +3163,28 @@ Tcl_GetBignumFromObj( Tcl_Interp* interp, * None. * * Side effects: - * Object value is stored. The bignum value is cleared, since - * ownership has transferred to Tcl. + * Object value is stored. The bignum value is cleared, since ownership + * has transferred to Tcl. * *---------------------------------------------------------------------- */ void -Tcl_SetBignumObj( Tcl_Obj* objPtr, - /* Object to set */ - mp_int* bignumValue ) - /* Value to store */ +Tcl_SetBignumObj( + Tcl_Obj* objPtr, /* Object to set */ + mp_int* bignumValue) /* Value to store */ { - if ( Tcl_IsShared( objPtr ) ) { - Tcl_Panic( "Tcl_SetBignumObj called with shared object" ); + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("Tcl_SetBignumObj called with shared object"); } - TclFreeIntRep( objPtr ); + TclFreeIntRep(objPtr); objPtr->typePtr = &tclBignumType; - PACK_BIGNUM( *bignumValue, objPtr ); - Tcl_InvalidateStringRep( objPtr ); + PACK_BIGNUM(*bignumValue, objPtr); + Tcl_InvalidateStringRep(objPtr); /* Clear the value with mp_init; mp_clear overwrites the digit array. */ - mp_init( bignumValue ); + mp_init(bignumValue); } /* @@ -3190,11 +3193,11 @@ Tcl_SetBignumObj( Tcl_Obj* objPtr, * Tcl_DbIncrRefCount -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before incrementing the ref count. + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before incrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just increments - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this procedure just increments the + * reference count of the object. * * Results: * None. @@ -3207,12 +3210,12 @@ Tcl_SetBignumObj( Tcl_Obj* objPtr, void Tcl_DbIncrRefCount(objPtr, file, line) - register Tcl_Obj *objPtr; /* The object we are registering a - * reference to. */ + register Tcl_Obj *objPtr; /* The object we are registering a reference + * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { @@ -3220,17 +3223,19 @@ Tcl_DbIncrRefCount(objPtr, file, line) fflush(stderr); Tcl_Panic("Trying to increment refCount of previously disposed object."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); @@ -3253,11 +3258,11 @@ Tcl_DbIncrRefCount(objPtr, file, line) * Tcl_DbDecrRefCount -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. This checks to see whether or not - * the memory has been freed before decrementing the ref count. + * TCL_MEM_DEBUG is defined. This checks to see whether or not the memory + * has been freed before decrementing the ref count. * - * When TCL_MEM_DEBUG is not defined, this procedure just decrements - * the reference count of the object. + * When TCL_MEM_DEBUG is not defined, this procedure just decrements the + * reference count of the object. * * Results: * None. @@ -3274,8 +3279,8 @@ Tcl_DbDecrRefCount(objPtr, file, line) * to. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { @@ -3283,17 +3288,19 @@ Tcl_DbDecrRefCount(objPtr, file, line) fflush(stderr); Tcl_Panic("Trying to decrement refCount of previously disposed object."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + tablePtr = tsdPtr->objThreadMap; if (!tablePtr) { Tcl_Panic("object table not initialized"); @@ -3323,11 +3330,11 @@ Tcl_DbDecrRefCount(objPtr, file, line) * Tcl_DbIsShared -- * * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It tests whether the object has a ref - * count greater than one. + * TCL_MEM_DEBUG is defined. It tests whether the object has a ref count + * greater than one. * - * When TCL_MEM_DEBUG is not defined, this procedure just tests - * if the object has a ref count greater than one. + * When TCL_MEM_DEBUG is not defined, this procedure just tests if the + * object has a ref count greater than one. * * Results: * None. @@ -3343,8 +3350,8 @@ Tcl_DbIsShared(objPtr, file, line) register Tcl_Obj *objPtr; /* The object to test for being shared. */ CONST char *file; /* The name of the source file calling this * procedure; used for debugging. */ - int line; /* Line number in the source file; used - * for debugging. */ + int line; /* Line number in the source file; used for + * debugging. */ { #ifdef TCL_MEM_DEBUG if (objPtr->refCount == 0x61616161) { @@ -3352,13 +3359,14 @@ Tcl_DbIsShared(objPtr, file, line) fflush(stderr); Tcl_Panic("Trying to check whether previously disposed object is shared."); } + # ifdef TCL_THREADS /* - * Check to make sure that the Tcl_Obj was allocated by the - * current thread. Don't do this check when shutting down - * since thread local storage can be finalized before the - * last Tcl_Obj is freed. + * Check to make sure that the Tcl_Obj was allocated by the current + * thread. Don't do this check when shutting down since thread local + * storage can be finalized before the last Tcl_Obj is freed. */ + if (!TclInExit()) { Tcl_HashTable *tablePtr; Tcl_HashEntry *hPtr; @@ -3376,6 +3384,7 @@ Tcl_DbIsShared(objPtr, file, line) } # endif #endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); if ((objPtr)->refCount <= 1) { @@ -3387,6 +3396,7 @@ Tcl_DbIsShared(objPtr, file, line) } Tcl_MutexUnlock(&tclObjMutex); #endif + return ((objPtr)->refCount > 1); } @@ -3395,8 +3405,8 @@ Tcl_DbIsShared(objPtr, file, line) * * Tcl_InitObjHashTable -- * - * Given storage for a hash table, set up the fields to prepare - * the hash table for use, the keys are Tcl_Obj *. + * Given storage for a hash table, set up the fields to prepare the hash + * table for use, the keys are Tcl_Obj *. * * Results: * None. @@ -3410,8 +3420,9 @@ Tcl_DbIsShared(objPtr, file, line) void Tcl_InitObjHashTable(tablePtr) - register Tcl_HashTable *tablePtr; /* Pointer to table record, which - * is supplied by the caller. */ + register Tcl_HashTable *tablePtr; + /* Pointer to table record, which is supplied + * by the caller. */ { Tcl_InitCustomHashTable(tablePtr, TCL_CUSTOM_PTR_KEYS, &tclObjHashKeyType); @@ -3456,8 +3467,8 @@ AllocObjEntry(tablePtr, keyPtr) * Compares two Tcl_Obj * keys. * * Results: - * The return value is 0 if they are different and 1 if they are - * the same. + * The return value is 0 if they are different and 1 if they are the + * same. * * Side effects: * None. @@ -3478,6 +3489,7 @@ CompareObjKeys(keyPtr, hPtr) /* * If the object pointers are the same then they match. */ + if (objPtr1 == objPtr2) { return 1; } @@ -3486,6 +3498,7 @@ CompareObjKeys(keyPtr, hPtr) * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being * in a register. */ + p1 = TclGetString(objPtr1); l1 = objPtr1->length; p2 = TclGetString(objPtr2); @@ -3494,6 +3507,7 @@ CompareObjKeys(keyPtr, hPtr) /* * Only compare if the string representations are of the same length. */ + if (l1 == l2) { for (;; p1++, p2++, l1--) { if (*p1 != *p2) { @@ -3543,8 +3557,8 @@ FreeObjEntry(hPtr) * Tcl_Obj, which can be used to generate a hash index. * * Results: - * The return value is a one-word summary of the information in - * the string representation of the Tcl_Obj. + * The return value is a one-word summary of the information in the + * string representation of the Tcl_Obj. * * Side effects: * None. @@ -3564,19 +3578,19 @@ HashObjKey(tablePtr, keyPtr) int i; /* - * I tried a zillion different hash functions and asked many other - * people for advice. Many people had their own favorite functions, - * all different, but no-one had much idea why they were good ones. - * I chose the one below (multiply by 9 and add new character) - * because of the following reasons: + * I tried a zillion different hash functions and asked many other people + * for advice. Many people had their own favorite functions, all + * different, but no-one had much idea why they were good ones. I chose + * the one below (multiply by 9 and add new character) because of the + * following reasons: * - * 1. Multiplying by 10 is perfect for keys that are decimal strings, - * and multiplying by 9 is just about as good. + * 1. Multiplying by 10 is perfect for keys that are decimal strings, and + * multiplying by 9 is just about as good. * 2. Times-9 is (shift-left-3) plus (old). This means that each - * character's bits hang around in the low-order bits of the - * hash value for ever, plus they spread fairly rapidly up to - * the high-order bits to fill out the hash value. This seems - * works well both for decimal and non-decimal strings. + * character's bits hang around in the low-order bits of the hash value + * for ever, plus they spread fairly rapidly up to the high-order bits + * to fill out the hash value. This seems works well both for decimal + * and *non-decimal strings. */ for (i=0 ; ivarFramePtr; @@ -3638,8 +3652,8 @@ Tcl_GetCommandFromObj(interp, objPtr) /* * Get the internal representation, converting to a command type if - * needed. The internal representation is a ResolvedCmdName that points - * to the actual command. + * needed. The internal representation is a ResolvedCmdName that points to + * the actual command. */ if (objPtr->typePtr != &tclCmdNameType) { @@ -3664,11 +3678,11 @@ Tcl_GetCommandFromObj(interp, objPtr) /* * Check the context namespace and the namespace epoch of the resolved * symbol to make sure that it is fresh. If not, then force another - * conversion to the command type, to discard the old rep and create a - * new one. Note that we verify that the namespace id of the context - * namespace is the same as the one we cached; this insures that the - * namespace wasn't deleted and a new one created at the same address - * with the same command epoch. + * conversion to the command type, to discard the old rep and create a new + * one. Note that we verify that the namespace id of the context namespace + * is the same as the one we cached; this insures that the namespace + * wasn't deleted and a new one created at the same address with the same + * command epoch. */ cmdPtr = NULL; @@ -3710,8 +3724,8 @@ Tcl_GetCommandFromObj(interp, objPtr) * * Side effects: * The object's old internal rep is freed. It's string rep is not - * changed. The refcount in the Command structure is incremented to - * keep it from being freed if the command is later deleted until + * changed. The refcount in the Command structure is incremented to keep + * it from being freed if the command is later deleted until * TclExecuteByteCode has a chance to recognize that it was deleted. * *---------------------------------------------------------------------- @@ -3721,8 +3735,8 @@ void TclSetCmdNameObj(interp, objPtr, cmdPtr) Tcl_Interp *interp; /* Points to interpreter containing command * that should be cached in objPtr. */ - register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to - * a CmdName object. */ + register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to a + * CmdName object. */ Command *cmdPtr; /* Points to Command structure that the * CmdName object should refer to. */ { @@ -3737,11 +3751,11 @@ TclSetCmdNameObj(interp, objPtr, cmdPtr) } /* - * If the variable name is fully qualified, do as if the lookup were - * done from the global namespace; this helps avoid repeated lookups - * of fully qualified names. It costs close to nothing, and may be very - * helpful for OO applications which pass along a command name ("this"), - * [Patch 456668] (Copied over from Tcl_GetCommandFromObj) + * If the variable name is fully qualified, do as if the lookup were done + * from the global namespace; this helps avoid repeated lookups of fully + * qualified names. It costs close to nothing, and may be very helpful for + * OO applications which pass along a command name ("this"), [Patch + * 456668] (Copied over from Tcl_GetCommandFromObj) */ savedFramePtr = iPtr->varFramePtr; @@ -3790,10 +3804,10 @@ TclSetCmdNameObj(interp, objPtr, cmdPtr) * * Side effects: * Decrements the ref count of any cached ResolvedCmdName structure - * pointed to by the cmdName's internal representation. If this is - * the last use of the ResolvedCmdName, it is freed. This in turn - * decrements the ref count of the Command structure pointed to by - * the ResolvedSymbol, which may free the Command structure. + * pointed to by the cmdName's internal representation. If this is the + * last use of the ResolvedCmdName, it is freed. This in turn decrements + * the ref count of the Command structure pointed to by the + * ResolvedSymbol, which may free the Command structure. * *---------------------------------------------------------------------- */ @@ -3808,16 +3822,16 @@ FreeCmdNameInternalRep(objPtr) if (resPtr != NULL) { /* - * Decrement the reference count of the ResolvedCmdName structure. - * If there are no more uses, free the ResolvedCmdName structure. + * Decrement the reference count of the ResolvedCmdName structure. If + * there are no more uses, free the ResolvedCmdName structure. */ resPtr->refCount--; if (resPtr->refCount == 0) { /* - * Now free the cached command, unless it is still in its - * hash table or if there are other references to it - * from other cmdName objects. + * Now free the cached command, unless it is still in its hash + * table or if there are other references to it from other cmdName + * objects. */ Command *cmdPtr = resPtr->cmdPtr; @@ -3832,17 +3846,17 @@ FreeCmdNameInternalRep(objPtr) * * DupCmdNameInternalRep -- * - * Initialize the internal representation of an cmdName Tcl_Obj to a - * copy of the internal representation of an existing cmdName object. + * Initialize the internal representation of an cmdName Tcl_Obj to a copy + * of the internal representation of an existing cmdName object. * * Results: * None. * * Side effects: * "copyPtr"s internal rep is set to point to the ResolvedCmdName - * structure corresponding to "srcPtr"s internal rep. Increments the - * ref count of the ResolvedCmdName structure pointed to by the - * cmdName's internal representation. + * structure corresponding to "srcPtr"s internal rep. Increments the ref + * count of the ResolvedCmdName structure pointed to by the cmdName's + * internal representation. * *---------------------------------------------------------------------- */ @@ -3852,8 +3866,8 @@ DupCmdNameInternalRep(srcPtr, copyPtr) Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { - register ResolvedCmdName *resPtr = - (ResolvedCmdName *) srcPtr->internalRep.twoPtrValue.ptr1; + register ResolvedCmdName *resPtr = (ResolvedCmdName *) + srcPtr->internalRep.twoPtrValue.ptr1; copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; @@ -3876,10 +3890,10 @@ DupCmdNameInternalRep(srcPtr, copyPtr) * * Side effects: * A pointer to a ResolvedCmdName structure that holds a cached pointer - * to the command with a name that matches objPtr's string rep is - * stored as objPtr's internal representation. This ResolvedCmdName - * pointer will be NULL if no matching command was found. The ref count - * of the cached Command's structure (if any) is also incremented. + * to the command with a name that matches objPtr's string rep is stored + * as objPtr's internal representation. This ResolvedCmdName pointer will + * be NULL if no matching command was found. The ref count of the cached + * Command's structure (if any) is also incremented. * *---------------------------------------------------------------------- */ @@ -3940,10 +3954,10 @@ SetCmdNameFromAny(interp, objPtr) } /* - * Free the old internalRep before setting the new one. We do this as - * late as possible to allow the conversion code, in particular - * GetStringFromObj, to use that old internalRep. If no Command - * structure was found, leave NULL as the cached value. + * Free the old internalRep before setting the new one. We do this as late + * as possible to allow the conversion code, in particular + * GetStringFromObj, to use that old internalRep. If no Command structure + * was found, leave NULL as the cached value. */ TclFreeIntRep(objPtr); @@ -3952,3 +3966,11 @@ SetCmdNameFromAny(interp, objPtr) objPtr->typePtr = &tclCmdNameType; return TCL_OK; } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ -- cgit v0.12