summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclBinary.c1676
-rw-r--r--generic/tclCmdAH.c1541
-rw-r--r--generic/tclCmdIL.c1138
-rw-r--r--generic/tclCmdMZ.c2816
-rw-r--r--generic/tclCompExpr.c538
-rw-r--r--generic/tclEncoding.c967
-rw-r--r--generic/tclEvent.c439
-rw-r--r--generic/tclFileName.c962
-rw-r--r--generic/tclIO.c3183
-rw-r--r--generic/tclIOCmd.c782
-rw-r--r--generic/tclIOGT.c1153
-rw-r--r--generic/tclIOUtil.c3224
-rw-r--r--generic/tclInterp.c2022
-rw-r--r--generic/tclLink.c146
-rw-r--r--generic/tclLoad.c439
-rw-r--r--generic/tclNamesp.c448
-rw-r--r--generic/tclObj.c1380
17 files changed, 11620 insertions, 11234 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 ; i<objc ; i++) {
argObjv[i] = objv[i];
}
/*
* Manage numList parallel value lists.
- * argvList[i] is a value list counted by argcList[i]
- * varvList[i] is the list of variables associated with the value list
- * varcList[i] is the number of variables associated with the value list
- * index[i] is the current pointer into the value list argvList[i]
+ * argvList[i] is a value list counted by argcList[i]l;
+ * varvList[i] is the list of variables associated with the value list;
+ * varcList[i] is the number of variables associated with the value list;
+ * index[i] is the current pointer into the value list argvList[i].
*/
numLists = (objc-2)/2;
@@ -1788,13 +1804,13 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
- * Break up the value lists and variable lists into elements
+ * Break up the value lists and variable lists into elements.
*/
maxj = 0;
- for (i = 0; i < numLists; i++) {
+ for (i=0 ; i<numLists ; i++) {
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
- &varcList[i], &varvList[i]);
+ &varcList[i], &varvList[i]);
if (result != TCL_OK) {
goto done;
}
@@ -1805,7 +1821,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
- &argcList[i], &argvList[i]);
+ &argcList[i], &argvList[i]);
if (result != TCL_OK) {
goto done;
}
@@ -1820,20 +1836,19 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
- * Iterate maxj times through the lists in parallel
- * If some value lists run out of values, set loop vars to ""
+ * Iterate maxj times through the lists in parallel. If some value lists
+ * run out of values, set loop vars to ""
*/
bodyPtr = argObjv[objc-1];
- for (j = 0; j < maxj; j++) {
- for (i = 0; i < numLists; i++) {
+ for (j=0 ; j<maxj ; j++) {
+ for (i=0 ; i<numLists ; i++) {
/*
- * Refetch the list members; we assume that the sizes are
- * the same, but the array of elements might be different
- * if the internal rep of the objects has been lost and
- * recreated (it is too difficult to accurately tell when
- * this happens, which can lead to some wierd crashes,
- * like Bug #494348...)
+ * Refetch the list members; we assume that the sizes are the
+ * same, but the array of elements might be different if the
+ * internal rep of the objects has been lost and recreated (it is
+ * too difficult to accurately tell when this happens, which can
+ * lead to some wierd crashes, like Bug #494348...)
*/
result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
@@ -1847,7 +1862,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
Tcl_Panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
}
- for (v = 0; v < varcList[i]; v++) {
+ for (v=0 ; v<varcList[i] ; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
int isEmptyObj = 0;
@@ -1870,7 +1885,6 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
result = TCL_ERROR;
goto done;
}
-
}
}
@@ -1882,7 +1896,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
result = TCL_OK;
break;
} else if (result == TCL_ERROR) {
- char msg[32 + TCL_INTEGER_SPACE];
+ char msg[32 + TCL_INTEGER_SPACE];
sprintf(msg, "\n (\"foreach\" body line %d)",
interp->errorLine);
@@ -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 ; i++) {
/*
- * We do this each time round the loop because that is robust
- * against shimmering nasties.
+ * We do this each time round the loop because that is robust against
+ * shimmering nasties.
*/
+
if (Tcl_ListObjIndex(interp, objv[1], i, &valueObj) != TCL_OK) {
return TCL_ERROR;
}
@@ -2326,11 +2327,13 @@ Tcl_LassignObjCmd(dummy, interp, objc, objv)
}
valueObj = emptyObj;
}
+
/*
- * Make sure the reference count for the value being assigned
- * is greater than one (other reference minimally in the list)
- * so we can't get hammered by shimmering.
+ * Make sure the reference count for the value being assigned is
+ * greater than one (other reference minimally in the list) so we
+ * can't get hammered by shimmering.
*/
+
Tcl_IncrRefCount(valueObj);
if (Tcl_ObjSetVar2(interp, objv[i+2], NULL, valueObj,
TCL_LEAVE_ERR_MSG) == NULL) {
@@ -2347,12 +2350,10 @@ Tcl_LassignObjCmd(dummy, interp, objc, objv)
}
/*
- * Now place a list of any values left over into the interpreter
- * result.
+ * Now place a list of any values left over into the interpreter result.
*
- * First, figure out how many values were not assigned by getting
- * the length of the list. Note that I do not expect this
- * operation to fail.
+ * First, figure out how many values were not assigned by getting the
+ * length of the list. Note that I do not expect this operation to fail.
*/
if (Tcl_ListObjGetElements(interp, objv[1],
@@ -2362,9 +2363,10 @@ Tcl_LassignObjCmd(dummy, interp, objc, objv)
if (listObjc > 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 ; i<indexCount ; i++) {
@@ -2541,6 +2543,7 @@ TclLindexList(interp, listPtr, argPtr)
/*
* Index is out of range
*/
+
Tcl_DecrRefCount(listPtr);
listPtr = Tcl_NewObj();
Tcl_IncrRefCount(listPtr);
@@ -2548,14 +2551,14 @@ TclLindexList(interp, listPtr, argPtr)
}
/*
- * Make sure listPtr still refers to a list object.
- * If it shared a Tcl_Obj structure with the arguments, then
- * it might have just been converted to something else.
+ * Make sure listPtr still refers to a list object. If it shared a
+ * Tcl_Obj structure with the arguments, then it might have just been
+ * converted to something else.
*/
if (listPtr->typePtr != &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<sortInfo.indexc ; j++) {
if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
char buffer[TCL_INTEGER_SPACE];
-
+
if (sortInfo.indexc > 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<sortInfo.indexc ; j++) {
if (TclGetIntForIndex(interp, indices[j], SORTIDX_END,
&sortInfo.indexv[j]) != TCL_OK) {
char buffer[TCL_INTEGER_SPACE];
-
+
if (sortInfo.indexc > 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 ; i<NUM_LISTS ; i++) {
subList[i] = NULL;
}
while (headPtr != NULL) {
elementPtr = headPtr;
headPtr = headPtr->nextPtr;
elementPtr->nextPtr = 0;
- for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
+ for (i=0 ; i<NUM_LISTS && subList[i]!=NULL ; i++) {
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
subList[i] = NULL;
}
@@ -4170,7 +4187,7 @@ MergeSort(headPtr, infoPtr)
subList[i] = elementPtr;
}
elementPtr = NULL;
- for (i = 0; i < NUM_LISTS; i++){
+ for (i=0 ; i<NUM_LISTS ; i++) {
elementPtr = MergeLists(subList[i], elementPtr, infoPtr);
}
return elementPtr;
@@ -4185,22 +4202,21 @@ MergeSort(headPtr, infoPtr)
* into a single sorted list.
*
* Results:
- * The unified list of SortElement structures.
+ * The unified list of SortElement structures.
*
* Side effects:
- * None, unless a user-defined comparison command does something
- * weird.
+ * None, unless a user-defined comparison command does something weird.
*
*----------------------------------------------------------------------
*/
static SortElement *
MergeLists(leftPtr, rightPtr, infoPtr)
- SortElement *leftPtr; /* First list to be merged; may be
+ SortElement *leftPtr; /* First list to be merged; may be
* NULL. */
- SortElement *rightPtr; /* Second list to be merged; may be
+ SortElement *rightPtr; /* Second list to be merged; may be
* NULL. */
- SortInfo *infoPtr; /* Information needed by the
+ SortInfo *infoPtr; /* Information needed by the
* comparison operator. */
{
SortElement *headPtr;
@@ -4257,14 +4273,13 @@ MergeLists(leftPtr, rightPtr, infoPtr)
* ordering between two elements.
*
* Results:
- * A negative results means the the first element comes before the
- * second, and a positive results 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 results means the the first element comes before the
+ * second, and a positive results 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, unless a user-defined comparison command does something
- * weird.
+ * None, unless a user-defined comparison command does something weird.
*
*----------------------------------------------------------------------
*/
@@ -4272,17 +4287,18 @@ MergeLists(leftPtr, rightPtr, infoPtr)
static int
SortCompare(objPtr1, objPtr2, infoPtr)
Tcl_Obj *objPtr1, *objPtr2; /* Values to be compared. */
- SortInfo *infoPtr; /* Information passed from the
- * top-level "lsort" command */
+ SortInfo *infoPtr; /* Information passed from the
+ * top-level "lsort" command. */
{
int order;
order = 0;
if (infoPtr->resultCode != 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 ; i<infoPtr->indexc ; 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,
&currentObj) != 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;
- }
+ 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;
+ 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) {
/*
- * We are searching string2 for the sequence string1.
+ * If a startIndex is specified, we will need to fast forward to
+ * that point in the string before we think about a match
*/
- match = -1;
- start = 0;
- length2 = -1;
+ 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;
+ }
+ }
- ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
- ustring2 = Tcl_GetUnicodeFromObj(objv[3], &length2);
+ if (length1 > 0) {
+ register Tcl_UniChar *p, *end;
- if (objc == 5) {
+ end = ustring2 + length2 - length1 + 1;
+ for (p = ustring2; p < end; p++) {
/*
- * If a startIndex is specified, we will need to fast
- * forward to that point in the string before we think
- * about a match
+ * Scan forward to find the first character.
*/
- 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;
+ if ((*p == *ustring1) && (TclUniCharNcmp(ustring1, p,
+ (unsigned long) length1) == 0)) {
+ match = p - ustring2;
+ break;
}
}
+ }
- if (length1 > 0) {
- register Tcl_UniChar *p, *end;
+ /*
+ * Compute the character index of the matching string by counting the
+ * number of characters before the match.
+ */
- 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;
- }
- }
- }
- /*
- * Compute the character index of the matching string by
- * counting the number of characters before the match.
- */
- if ((match != -1) && (objc == 5)) {
- match += start;
- }
+ if ((match != -1) && (objc == 5)) {
+ match += start;
+ }
- str_first_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
- break;
+ 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;
}
- case STR_INDEX: {
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "string charIndex");
+
+ /*
+ * 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 ((index >= 0) && (index < length1)) {
+ Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
+ (unsigned char *)(&string1[index]), 1));
+ }
+ } else {
/*
- * 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.
+ * Get Unicode char length to calulate what 'end' means.
*/
- if (objv[2]->typePtr == &tclByteArrayType) {
- string1 = (char *) Tcl_GetByteArrayFromObj(objv[2], &length1);
+ length1 = Tcl_GetCharLength(objv[2]);
- 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 {
- /*
- * Get Unicode char length to calulate what 'end' means.
- */
- 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;
+ 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));
- }
+ 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;
+ break;
+ }
+ case STR_IS: {
+ char *end;
+ Tcl_UniChar ch;
- /*
- * The UniChar comparison function
- */
+ /*
+ * 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) &&
+ 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;
- }
- failVarObj = objv[++i];
- } else {
- Tcl_AppendResult(interp, "bad option \"",
- string2, "\": must be -strict or -failindex",
- (char *) NULL);
+ 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;
}
}
+ }
- /*
- * 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
- */
- objPtr = objv[objc-1];
- string1 = Tcl_GetStringFromObj(objPtr, &length1);
- if (length1 == 0) {
- if (strict) {
+ /*
+ * 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
+ */
+
+ 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;
+ break;
}
- goto str_is_done;
}
- end = string1 + length1;
+ 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 ((objPtr->typePtr == &tclDoubleType) ||
+ (objPtr->typePtr == &tclIntType)) {
+ break;
+ }
/*
- * When entering here, result == 1 and failat == 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.
*/
- 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;
- 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;
+ if (TclLooksLikeInt(string1, length1)) {
+ errno = 0;
#ifdef TCL_WIDE_INT_IS_LONG
- strtoul(string1, &stop, 0); /* INTL: Tcl source. */
+ strtoul(string1, &stop, 0); /* INTL: Tcl source. */
#else
- strtoull(string1, &stop, 0); /* INTL: Tcl source. */
+ 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
- */
+ if (stop == end) {
+ if (errno == ERANGE) {
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;
- }
- 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;
- }
-
- /*
- * Like STR_IS_DOUBLE, but we use strtoul.
- * Since Tcl_GetIntFromObj already failed,
- * we set result to 0.
- */
-
- 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;
-
- if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
- break;
- }
+ }
+ errno = 0;
+ TclStrToD(string1, (CONST char **) &stop); /* INTL: Tcl source. */
+ if (stop == string1) {
+ /*
+ * In this case, nothing like a number was found.
+ */
- /*
- * Like STR_IS_DOUBLE, but we use strtoll. Since
- * Tcl_GetWideIntFromObj already failed, we set
- * result to 0.
- */
+ 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.
+ */
- 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.
- */
- 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;
- }
+ failat = stop - string1;
+ string1 = stop;
+ chcomp = Tcl_UniCharIsSpace;
}
- if (chcomp != NULL) {
- for (; string1 < end; string1 += length2, failat++) {
- length2 = TclUtfToUniChar(string1, &ch);
- if (!chcomp(ch)) {
- result = 0;
- break;
- }
- }
- }
- str_is_done:
- /*
- * Only set the failVarObj when we will return 0
- * and we have indicated a valid fail index (>= 0)
- */
- 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;
+ case STR_IS_GRAPH:
+ chcomp = Tcl_UniCharIsGraph;
+ break;
+ case STR_IS_INT: {
+ char *stop;
+ long int l = 0;
- if (objc < 4 || objc > 5) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "subString string ?startIndex?");
- return TCL_ERROR;
+ if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &i)) {
+ break;
}
/*
- * We are searching string2 for the sequence string1.
+ * Like STR_IS_DOUBLE, but we use strtoul. Since Tcl_GetIntFromObj
+ * 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;
+ 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.
+ */
- 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;
}
-
- 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;
+ 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 (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
+ break;
}
- if ((enum options) index == STR_BYTELENGTH) {
- (void) Tcl_GetStringFromObj(objv[2], &length1);
+ /*
+ * Like STR_IS_DOUBLE, but we use strtoll. Since
+ * Tcl_GetWideIntFromObj already failed, we set result to 0.
+ */
+
+ 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.
+ */
+
+ failat = -1;
+ } else if (stop == string1) {
+ /*
+ * In this case, nothing like a number was found
+ */
+ failat = 0;
} 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.
+ * Assume we sucked up one char per byte and then we go onto
+ * SPACE, since we are allowed trailing whitespace.
*/
- if (objv[2]->typePtr == &tclByteArrayType) {
- (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
- } else {
- length1 = Tcl_GetCharLength(objv[2]);
- }
+ failat = stop - string1;
+ string1 = stop;
+ chcomp = Tcl_UniCharIsSpace;
}
- 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;
+ 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;
+ }
}
-
- 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;
+ break;
+ }
+ if (chcomp != NULL) {
+ for (; string1 < end; string1 += length2, failat++) {
+ length2 = TclUtfToUniChar(string1, &ch);
+ if (!chcomp(ch)) {
+ result = 0;
+ break;
}
}
+ }
+ /*
+ * 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) {
/*
- * 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 a startIndex is specified, we will need to restrict the
+ * string range to that char index in the string
*/
- if (objv[objc-2]->typePtr == &tclDictType &&
- objv[objc-2]->bytes == NULL) {
- int i, done;
- Tcl_DictSearch search;
+ 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--) {
/*
- * 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;
- /*
- * Copy the dictionary out into an array; that's the
- * easiest way to adapt this code...
+ * Scan backwards to find the first character.
*/
- mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc);
- Tcl_DictObjFirst(interp, objv[objc-2], &search,
- mapElemv+0, mapElemv+1, &done);
- for (i=2 ; i<mapElemc ; i+=2) {
- Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
- }
- } else {
- if (Tcl_ListObjGetElements(interp, objv[objc-2],
- &mapElemc, &mapElemv) != TCL_OK) {
- return TCL_ERROR;
- }
- if (mapElemc == 0) {
- /*
- * empty charMap, just return whatever string was given
- */
- Tcl_SetObjResult(interp, objv[objc-1]);
- return TCL_OK;
- } else if (mapElemc & 1) {
- /*
- * The charMap must be an even number of key/value items
- */
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "char map list unbalanced", -1));
- return TCL_ERROR;
+
+ if ((*p == *ustring1) &&
+ (memcmp((char *) ustring1, (char *) p, (size_t)
+ (length1 * sizeof(Tcl_UniChar))) == 0)) {
+ match = p - ustring2;
+ 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 ((enum options) index == STR_BYTELENGTH) {
+ (void) Tcl_GetStringFromObj(objv[2], &length1);
+ } else {
/*
- * 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]
+ * 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[objc-2] == objv[objc-1]) {
- sourceObj = Tcl_DuplicateObj(objv[objc-1]);
- copySource = 1;
+
+ if (objv[2]->typePtr == &tclByteArrayType) {
+ (void) Tcl_GetByteArrayFromObj(objv[2], &length1);
} else {
- sourceObj = objv[objc-1];
+ length1 = Tcl_GetCharLength(objv[2]);
}
- 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;
+ }
+ 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;
}
- end = ustring1 + length1;
+ }
+
+ /*
+ * This test is tricky, but has to be that way or you get other
+ * strange inconsistencies (see test string-10.20 for illustration
+ * why!)
+ */
- strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp;
+ if (objv[objc-2]->typePtr == &tclDictType &&
+ objv[objc-2]->bytes == NULL) {
+ int i, done;
+ Tcl_DictSearch search;
/*
- * Force result to be Unicode
+ * We know the type exactly, so all dict operations will succeed
+ * for sure. This shortens this code quite a bit.
*/
- resultPtr = Tcl_NewUnicodeObj(ustring1, 0);
- if (mapElemc == 2) {
+ Tcl_DictObjSize(interp, objv[objc-2], &mapElemc);
+ if (mapElemc == 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.
+ * empty charMap, just return whatever string was given
*/
- 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);
- }
- }
- }
- } else {
- Tcl_UniChar **mapStrings, *u2lc = NULL;
- int *mapLens;
+
+ Tcl_SetObjResult(interp, objv[objc-1]);
+ return TCL_OK;
+ }
+
+ mapElemc *= 2;
+ mapWithDict = 1;
+
+ /*
+ * Copy the dictionary out into an array; that's the easiest way
+ * to adapt this code...
+ */
+
+ mapElemv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * mapElemc);
+ Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
+ mapElemv+1, &done);
+ for (i=2 ; i<mapElemc ; i+=2) {
+ Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done);
+ }
+ } else {
+ if (Tcl_ListObjGetElements(interp, objv[objc-2],
+ &mapElemc, &mapElemv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (mapElemc == 0) {
/*
- * 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.
+ * empty charMap, just return whatever string was given.
*/
- 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;
- }
- }
- }
- ckfree((char *) mapStrings);
- ckfree((char *) mapLens);
- if (nocase) {
- ckfree((char *) u2lc);
- }
- }
- if (p != ustring1) {
+ Tcl_SetObjResult(interp, objv[objc-1]);
+ return TCL_OK;
+ } else if (mapElemc & 1) {
/*
- * Put the rest of the unmapped chars onto result
+ * The charMap must be an even number of key/value items.
*/
- Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p);
+
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "char map list unbalanced", -1));
+ return TCL_ERROR;
}
+ }
+
+ /*
+ * 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]
+ */
+
+ if (objv[objc-2] == objv[objc-1]) {
+ sourceObj = Tcl_DuplicateObj(objv[objc-1]);
+ copySource = 1;
+ } else {
+ sourceObj = objv[objc-1];
+ }
+ ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1);
+ if (length1 == 0) {
+ /*
+ * Empty input string, just stop now.
+ */
+
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;
+ end = ustring1 + length1;
- if (objc < 4 || objc > 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "?-nocase? pattern string");
- return TCL_ERROR;
- }
+ strCmpFn = (nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp);
- 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;
- }
- }
- 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;
- }
+ /*
+ * Force result to be Unicode
+ */
+ resultPtr = Tcl_NewUnicodeObj(ustring1, 0);
+ if (mapElemc == 2) {
/*
- * 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.
+ * 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.
*/
- if (objv[2]->typePtr == &tclByteArrayType) {
- string1 = (char *)Tcl_GetByteArrayFromObj(objv[2], &length1);
- length1--;
- } else {
+ int mapLen;
+ Tcl_UniChar *mapString, u2lc;
+
+ ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2);
+ p = ustring1;
+ if ((length2 > length1) || (length2 == 0)) {
/*
- * Get the length in actual characters.
+ * Match string is either longer than input or empty.
*/
- 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;
- }
+ 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;
- 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));
+ Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen);
+ }
}
}
- break;
- }
- case STR_REPEAT: {
- int count;
+ } else {
+ Tcl_UniChar **mapStrings, *u2lc = NULL;
+ int *mapLens;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "string count");
- return TCL_ERROR;
- }
+ /*
+ * 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.
+ */
- if (Tcl_GetIntFromObj(interp, objv[3], &count) != TCL_OK) {
- return TCL_ERROR;
+ 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));
}
-
- 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;
- }
+ 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) {
/*
- * Include space for the NULL
+ * Get the key string to match on.
*/
- string2 = (char *) ckalloc((size_t) length2+1);
- for (index = 0; index < count; index++) {
- memcpy(string2 + (length1 * index), string1,
- (size_t) length1);
+
+ 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[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);
}
}
- break;
+ ckfree((char *) mapStrings);
+ ckfree((char *) mapLens);
+ if (nocase) {
+ ckfree((char *) u2lc);
+ }
+ }
+ if (p != ustring1) {
+ /*
+ * Put the rest of the unmapped chars onto result.
+ */
+
+ 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;
}
- case STR_REPLACE: {
- Tcl_UniChar *ustring1;
- int first, last;
- if (objc < 5 || objc > 6) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "string first last ?string?");
+ 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;
}
+ }
+ 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;
+ }
- ustring1 = Tcl_GetUnicodeFromObj(objv[2], &length1);
+ /*
+ * 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.
+ */
- if ((TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK)
- || (TclGetIntForIndex(interp, objv[4], length1,
- &last) != TCL_OK)) {
- return TCL_ERROR;
- }
+ string1 = NULL;
+ length1 = Tcl_GetCharLength(objv[2]) - 1;
+ }
- if ((last < first) || (last < 0) || (first > length1)) {
- Tcl_SetObjResult(interp, objv[2]);
- } else {
- Tcl_Obj *resultPtr;
- if (first < 0) {
- first = 0;
- }
+ if (TclGetIntForIndex(interp, objv[3], length1, &first) != TCL_OK ||
+ TclGetIntForIndex(interp, objv[4], length1, &last) != TCL_OK) {
+ return TCL_ERROR;
+ }
- 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);
- }
- break;
+ if (first < 0) {
+ first = 0;
}
- 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 >= 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));
}
+ }
+ break;
+ }
+ 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;
+ }
+
+ 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]
+ */
- 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)) {
+ 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;
}
- 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;
- 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;
-
- 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.
+ * Include space for the NULL.
*/
- 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;
- }
- }
+ string2 = (char *) ckalloc((size_t) length2+1);
+ for (index = 0; index < count; index++) {
+ memcpy(string2 + (length1 * index), string1,
+ (size_t) length1);
}
- }
- if (right) {
- end = string1;
+ string2[length2] = '\0';
/*
- * 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.
+ * We have to directly assign this instead of using
+ * Tcl_SetStringObj (and indirectly TclInitStringRep) because
+ * that makes another copy of the data.
*/
- 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;
- }
- }
- }
+ TclNewObj(resultPtr);
+ resultPtr->bytes = string2;
+ resultPtr->length = length2;
+ Tcl_SetObjResult(interp, resultPtr);
}
- 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;
+ break;
+ }
+ case STR_REPLACE: {
+ Tcl_UniChar *ustring1;
+ int first, last;
+
+ if (objc < 5 || objc > 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "string first last ?string?");
+ return TCL_ERROR;
+ }
+
+ 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 ((last < first) || (last < 0) || (first > length1)) {
+ Tcl_SetObjResult(interp, objv[2]);
+ } else {
+ Tcl_Obj *resultPtr;
+ if (first < 0) {
+ first = 0;
}
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- numChars = Tcl_NumUtfChars(string1, length1);
- if (TclGetIntForIndex(interp, objv[3], numChars-1,
- &index) != TCL_OK) {
- return TCL_ERROR;
+ resultPtr = Tcl_NewUnicodeObj(ustring1, first);
+ if (objc == 6) {
+ Tcl_AppendObjToObj(resultPtr, objv[5]);
}
- if (index < 0) {
- index = 0;
+ if (last < length1) {
+ Tcl_AppendUnicodeToObj(resultPtr, ustring1 + last + 1,
+ length1 - last);
}
- 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 (cur == index) {
- cur++;
- }
+ 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;
+ }
+
+ 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 {
- cur = numChars;
+ length1 = Tcl_UtfToTitle(TclGetString(resultPtr));
}
- 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");
+ 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;
- string1 = Tcl_GetStringFromObj(objv[2], &length1);
- numChars = Tcl_NumUtfChars(string1, length1);
- if (TclGetIntForIndex(interp, objv[3], numChars-1,
- &index) != TCL_OK) {
+ if ((objc == 5) && (TclGetIntForIndex(interp, objv[4], length1,
+ &last) != TCL_OK)) {
return TCL_ERROR;
}
- if (index >= numChars) {
- index = numChars - 1;
+
+ 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;
+
+ 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;
+
+ 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.
+ */
+
+ 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;
+ }
+ }
}
- cur = 0;
- if (index > 0) {
- p = Tcl_UtfAtIndex(string1, index);
- for (cur = index; cur >= 0; cur--) {
- TclUtfToUniChar(p, &ch);
- if (!Tcl_UniCharIsWordChar(ch)) {
+ }
+ if (right) {
+ end = string1;
+
+ /*
+ * 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;
}
- p = Tcl_UtfPrev(p, string1);
}
- if (cur != index) {
- cur += 1;
+ }
+ }
+ 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;
+ }
+ 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;
}
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(cur));
- 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;
+ }
+
+ 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;
+ }
}
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; j<numFiles; j++) {
@@ -517,7 +522,7 @@ FillEncodingFileMap()
* TclInitEncodingSubsystem --
*
* Initialize all resources used by this subsystem on a per-process
- * basis.
+ * basis.
*
* Results:
* None.
@@ -540,11 +545,11 @@ TclInitEncodingSubsystem()
Tcl_MutexLock(&encodingMutex);
Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS);
Tcl_MutexUnlock(&encodingMutex);
-
+
/*
- * Create a few initial encodings. 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.
+ * Create a few initial encodings. 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.
*/
type.encodingName = "identity";
@@ -599,19 +604,22 @@ TclFinalizeEncodingSubsystem()
Tcl_HashEntry *hPtr;
Tcl_MutexLock(&encodingMutex);
- encodingsInitialized = 0;
+ encodingsInitialized = 0;
FreeEncoding(systemEncoding);
+
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
while (hPtr != NULL) {
/*
* Call FreeEncoding instead of doing it directly to handle refcounts
- * like escape encodings use. [Bug #524674]
- * Make sure to call Tcl_FirstHashEntry repeatedly so that all
- * encodings are eventually cleaned up.
+ * like escape encodings use. [Bug #524674] Make sure to call
+ * Tcl_FirstHashEntry repeatedly so that all encodings are eventually
+ * cleaned up.
*/
+
FreeEncoding((Tcl_Encoding) Tcl_GetHashValue(hPtr));
hPtr = Tcl_FirstHashEntry(&encodingTable, &search);
}
+
Tcl_DeleteHashTable(&encodingTable);
Tcl_MutexUnlock(&encodingMutex);
}
@@ -621,12 +629,12 @@ TclFinalizeEncodingSubsystem()
*
* Tcl_GetDefaultEncodingDir --
*
- * Legacy public interface to retrieve first directory in the
- * encoding searchPath.
+ * Legacy public interface to retrieve first directory in the encoding
+ * searchPath.
*
* Results:
- * The directory pathname, as a string, or NULL for an empty
- * encoding search path.
+ * The directory pathname, as a string, or NULL for an empty encoding
+ * search path.
*
* Side effects:
* None.
@@ -654,8 +662,8 @@ Tcl_GetDefaultEncodingDir()
*
* Tcl_SetDefaultEncodingDir --
*
- * Legacy public interface to set the first directory in the
- * encoding search path.
+ * Legacy public interface to set the first directory in the encoding
+ * search path.
*
* Results:
* None.
@@ -689,16 +697,16 @@ Tcl_SetDefaultEncodingDir(path)
*
* Results:
* Returns a token that represents the encoding. If the name didn't
- * refer to any known or loadable encoding, NULL is returned. If
- * NULL was returned, an error message is left in interp's result
- * object, unless interp was NULL.
+ * refer to any known or loadable encoding, NULL is returned. If NULL
+ * was returned, an error message is left in interp's result object,
+ * unless interp was NULL.
*
* 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.
*
*-------------------------------------------------------------------------
*/
@@ -727,6 +735,7 @@ Tcl_GetEncoding(interp, name)
return (Tcl_Encoding) encodingPtr;
}
Tcl_MutexUnlock(&encodingMutex);
+
return LoadEncodingFile(interp, name);
}
@@ -742,8 +751,8 @@ Tcl_GetEncoding(interp, name)
* None.
*
* Side effects:
- * The reference count associated with the encoding is decremented
- * and the encoding may be deleted if nothing is using it anymore.
+ * The reference count associated with the encoding is decremented and
+ * the encoding may be deleted if nothing is using it anymore.
*
*---------------------------------------------------------------------------
*/
@@ -762,15 +771,15 @@ Tcl_FreeEncoding(encoding)
*
* FreeEncoding --
*
- * This procedure is called to release an encoding by procedures
- * that already have the encodingMutex.
+ * This procedure is called to release an encoding by procedures that
+ * already have the encodingMutex.
*
* Results:
* None.
*
* Side effects:
- * The reference count associated with the encoding is decremented
- * and the encoding may be deleted if nothing is using it anymore.
+ * The reference count associated with the encoding is decremented and
+ * the encoding may be deleted if nothing is using it anymore.
*
*----------------------------------------------------------------------
*/
@@ -780,7 +789,7 @@ FreeEncoding(encoding)
Tcl_Encoding encoding;
{
Encoding *encodingPtr;
-
+
encodingPtr = (Encoding *) encoding;
if (encodingPtr == NULL) {
return;
@@ -803,8 +812,8 @@ FreeEncoding(encoding)
*
* Tcl_GetEncodingName --
*
- * Given an encoding, return the name that was used to constuct
- * the encoding.
+ * Given an encoding, return the name that was used to constuct the
+ * encoding.
*
* Results:
* The name of the encoding.
@@ -819,13 +828,11 @@ CONST char *
Tcl_GetEncodingName(encoding)
Tcl_Encoding encoding; /* The encoding whose name to fetch. */
{
- Encoding *encodingPtr;
-
if (encoding == NULL) {
encoding = systemEncoding;
}
- encodingPtr = (Encoding *) encoding;
- return encodingPtr->name;
+
+ 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; i<numDirs && (chan == NULL); i++) {
path = Tcl_FSJoinToPath(dir[i], 1, &fileNameObj);
Tcl_IncrRefCount(path);
chan = Tcl_FSOpenFileChannel(NULL, path, "r", 0);
Tcl_DecrRefCount(path);
if (chan != NULL) {
- /* Save directory in the cache */
+ /*
+ * Save directory in the cache.
+ */
+
map = Tcl_DuplicateObj(TclGetProcessGlobalValue(&encodingFileMap));
Tcl_DictObjPut(NULL, map, nameObj, dir[i]);
TclSetProcessGlobalValue(&encodingFileMap, map, NULL);
}
}
+
if ((NULL == chan) && (interp != NULL)) {
Tcl_AppendResult(interp, "unknown encoding \"", name, "\"", NULL);
}
Tcl_DecrRefCount(fileNameObj);
Tcl_DecrRefCount(nameObj);
Tcl_DecrRefCount(searchPath);
+
return chan;
}
@@ -1470,17 +1510,17 @@ OpenEncodingFileChannel(interp, name)
*
* LoadEncodingFile --
*
- * Read a file that describes an encoding and create a new Encoding
- * from the data.
+ * Read a file that describes an encoding and create a new Encoding from
+ * the data.
*
* Results:
- * The return value is the newly loaded Encoding, or NULL if
- * the file didn't exist of was in the incorrect format. If NULL was
- * returned, an error message is left in interp's result object,
- * unless interp was NULL.
+ * The return value is the newly loaded Encoding, or NULL if the file
+ * didn't exist of was in the incorrect format. If NULL was returned, an
+ * error message is left in interp's result object, unless interp was
+ * NULL.
*
* Side effects:
- * File read from disk.
+ * File read from disk.
*
*---------------------------------------------------------------------------
*/
@@ -1488,8 +1528,8 @@ OpenEncodingFileChannel(interp, name)
static Tcl_Encoding
LoadEncodingFile(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_Channel chan = NULL;
Tcl_Encoding encoding = NULL;
@@ -1515,27 +1555,24 @@ LoadEncodingFile(interp, name)
}
switch (ch) {
- case 'S': {
- encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan);
- break;
- }
- case 'D': {
- encoding = LoadTableEncoding(name, ENCODING_DOUBLEBYTE, chan);
- break;
- }
- case 'M': {
- encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
- break;
- }
- case 'E': {
- encoding = LoadEscapeEncoding(name, chan);
- break;
- }
+ case 'S':
+ encoding = LoadTableEncoding(name, ENCODING_SINGLEBYTE, chan);
+ break;
+ case 'D':
+ encoding = LoadTableEncoding(name, ENCODING_DOUBLEBYTE, chan);
+ break;
+ case 'M':
+ encoding = LoadTableEncoding(name, ENCODING_MULTIBYTE, chan);
+ break;
+ case 'E':
+ encoding = LoadEscapeEncoding(name, chan);
+ break;
}
if ((encoding == NULL) && (interp != NULL)) {
Tcl_AppendResult(interp, "invalid encoding file \"", name, "\"", NULL);
}
Tcl_Close(NULL, chan);
+
return encoding;
}
@@ -1544,17 +1581,17 @@ LoadEncodingFile(interp, name)
*
* LoadTableEncoding --
*
- * Helper function for LoadEncodingTable(). Loads a table to that
- * converts between Unicode and some other encoding and creates an
+ * Helper function for LoadEncodingTable(). Loads a table to that
+ * converts between Unicode and some other encoding and creates an
* encoding (using a TableEncoding structure) from that information.
*
- * File contains binary data, but begins with a marker to indicate
- * byte-ordering, so that same binary file can be read on either
- * endian platforms.
+ * File contains binary data, but begins with a marker to indicate
+ * byte-ordering, so that same binary file can be read on either endian
+ * platforms.
*
* 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.
@@ -1629,8 +1666,8 @@ LoadTableEncoding(name, type, chan)
/*
* Read the table that maps characters to Unicode. Performs a single
- * malloc to get the memory for the array and all the pages needed by
- * the array.
+ * malloc to get the memory for the array and all the pages needed by the
+ * array.
*/
size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
@@ -1646,15 +1683,15 @@ LoadTableEncoding(name, type, chan)
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
p = Tcl_GetString(objPtr);
- hi = (staticHex[(unsigned int)p[0]] << 4) + staticHex[(unsigned int)p[1]];
+ hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[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
* "~<user>" (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 <assert.h>
-
/*
- * 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 <a.kupries@westend.com>, 12/13/1998
- * "Trf-Patch for filtering channels"
+ * Andreas Kupries <a.kupries@westend.com>, 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 "<specific options>"
- * 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 "<specific options>" 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 <v2 channel versions, the version field is occupied
- * by the Tcl_DriverBlockModeProc
+ * In <v2 channel versions, the version field is occupied by the
+ * Tcl_DriverBlockModeProc
*/
return TCL_CHANNEL_VERSION_1;
@@ -9416,8 +9350,8 @@ Tcl_ChannelWideSeekProc(chanTypePtr)
*
* Tcl_ChannelThreadActionProc --
*
- * TIP #218, Channel Thread Actions.
- * Return the Tcl_DriverThreadActionProc of the channel type.
+ * TIP #218, Channel Thread Actions. Return the
+ * Tcl_DriverThreadActionProc of the channel type.
*
* Results:
* A pointer to the proc.
@@ -9444,7 +9378,7 @@ Tcl_ChannelThreadActionProc(chanTypePtr)
*
* Tcl_ChannelTruncateProc --
*
- * TIP #208 (subsection relating to truncation, based on TIP #206).
+ * TIP #208 (subsection relating to truncation, based on TIP #206).
* Return the Tcl_DriverTruncateProc of the channel type.
*
* Results:
@@ -9469,41 +9403,52 @@ Tcl_ChannelTruncateProc(chanTypePtr)
#if 0
/*
- * For future debugging work, a simple function to print the flags of
- * a channel in semi-readable form.
+ * For future debugging work, a simple function to print the flags of a
+ * channel in semi-readable form.
*/
static int
DumpFlags(str, flags)
- char *str;
- int flags;
+ char *str;
+ int flags;
{
char buf[20];
int i = 0;
- if (flags & TCL_READABLE) buf[i++] = 'r'; else buf[i++]='_';
- if (flags & TCL_WRITABLE) buf[i++] = 'w'; else buf[i++]='_';
- if (flags & CHANNEL_NONBLOCKING) buf[i++] = 'n'; else buf[i++]='_';
- if (flags & CHANNEL_LINEBUFFERED) buf[i++] = 'l'; else buf[i++]='_';
- if (flags & CHANNEL_UNBUFFERED) buf[i++] = 'u'; else buf[i++]='_';
- if (flags & BUFFER_READY) buf[i++] = 'R'; else buf[i++]='_';
- if (flags & BG_FLUSH_SCHEDULED) buf[i++] = 'F'; else buf[i++]='_';
- if (flags & CHANNEL_CLOSED) buf[i++] = 'c'; else buf[i++]='_';
- if (flags & CHANNEL_EOF) buf[i++] = 'E'; else buf[i++]='_';
- if (flags & CHANNEL_STICKY_EOF) buf[i++] = 'S'; else buf[i++]='_';
- if (flags & CHANNEL_BLOCKED) buf[i++] = 'B'; else buf[i++]='_';
- if (flags & INPUT_SAW_CR) buf[i++] = '/'; else buf[i++]='_';
- if (flags & INPUT_NEED_NL) buf[i++] = '*'; else buf[i++]='_';
- if (flags & CHANNEL_DEAD) buf[i++] = 'D'; else buf[i++]='_';
- if (flags & CHANNEL_RAW_MODE) buf[i++] = 'R'; else buf[i++]='_';
+#define ChanFlag(chr,bit) (buf[i++] = ((flags & (bit)) ? (chr) : '_'))
+
+ ChanFlag('r', TCL_READABLE);
+ ChanFlag('w', TCL_WRITABLE);
+ ChanFlag('n', CHANNEL_NONBLOCKING);
+ ChanFlag('l', CHANNEL_LINEBUFFERED);
+ ChanFlag('u', CHANNEL_UNBUFFERED);
+ ChanFlag('R', BUFFER_READY);
+ ChanFlag('F', BG_FLUSH_SCHEDULED);
+ ChanFlag('c', CHANNEL_CLOSED);
+ ChanFlag('E', CHANNEL_EOF);
+ ChanFlag('S', CHANNEL_STICKY_EOF);
+ ChanFlag('B', CHANNEL_BLOCKED);
+ ChanFlag('/', INPUT_SAW_CR);
+ ChanFlag('*', INPUT_NEED_NL);
+ ChanFlag('D', CHANNEL_DEAD);
+ ChanFlag('R', CHANNEL_RAW_MODE);
#ifdef TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING
- if (flags & CHANNEL_TIMER_FEV) buf[i++] = 'T'; else buf[i++]='_';
- if (flags & CHANNEL_HAS_MORE_DATA) buf[i++] = 'H'; else buf[i++]='_';
+ ChanFlag('T', CHANNEL_TIMER_FEV);
+ ChanFlag('H', CHANNEL_HAS_MORE_DATA);
#endif /* TCL_IO_TRACK_OS_FOR_DRIVER_WITH_BAD_BLOCKING */
- if (flags & CHANNEL_INCLOSE) buf[i++] = 'x'; else buf[i++]='_';
+ ChanFlag('x', CHANNEL_INCLOSE);
+
buf[i] ='\0';
- fprintf(stderr,"%s: %s\n", str, buf);
+ fprintf(stderr, "%s: %s\n", str, buf);
return 0;
}
#endif
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index f33bde5..7403310 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1,14 +1,14 @@
-/*
+/*
* tclIOCmd.c --
*
* Contains the definitions of most of the Tcl commands relating to IO.
*
* 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: tclIOCmd.c,v 1.27 2005/06/07 10:05:00 dkf Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.28 2005/07/17 21:17:41 dkf Exp $
*/
#include "tclInt.h"
@@ -27,9 +27,9 @@ typedef struct AcceptCallback {
*/
static void AcceptCallbackProc _ANSI_ARGS_((ClientData callbackData,
- Tcl_Channel chan, char *address, int port));
+ Tcl_Channel chan, char *address, int port));
static void RegisterTcpServerInterpCleanup _ANSI_ARGS_((Tcl_Interp *interp,
- AcceptCallback *acceptCallbackPtr));
+ AcceptCallback *acceptCallbackPtr));
static void TcpAcceptCallbacksDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
static void TcpServerCloseProc _ANSI_ARGS_((ClientData callbackData));
@@ -41,8 +41,8 @@ static void UnregisterTcpServerInterpCleanupProc _ANSI_ARGS_((
*
* Tcl_PutsObjCmd --
*
- * This procedure is invoked to process the "puts" Tcl command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the "puts" Tcl command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -61,21 +61,21 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to puts on. */
- Tcl_Obj *string; /* String to write. */
- int newline; /* Add a newline at end? */
- char *channelId; /* Name of channel for puts. */
- int result; /* Result of puts operation. */
- int mode; /* Mode in which channel is opened. */
+ Tcl_Channel chan; /* The channel to puts on. */
+ Tcl_Obj *string; /* String to write. */
+ int newline; /* Add a newline at end? */
+ char *channelId; /* Name of channel for puts. */
+ int result; /* Result of puts operation. */
+ int mode; /* Mode in which channel is opened. */
switch (objc) {
- case 2: /* puts $x */
+ case 2: /* [puts $x] */
string = objv[1];
newline = 1;
channelId = "stdout";
break;
- case 3: /* puts -nonewline $x or puts $chan $x */
+ case 3: /* [puts -nonewline $x] or [puts $chan $x] */
if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
newline = 0;
channelId = "stdout";
@@ -86,15 +86,15 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
string = objv[2];
break;
- case 4: /* puts -nonewline $chan $x or puts $chan $x nonewline */
+ case 4: /* [puts -nonewline $chan $x] or [puts $chan $x nonewline] */
if (strcmp(Tcl_GetString(objv[1]), "-nonewline") == 0) {
channelId = Tcl_GetString(objv[2]);
string = objv[3];
} else {
/*
- * The code below provides backwards compatibility with an
- * old form of the command that is no longer recommended
- * or documented.
+ * The code below provides backwards compatibility with an old
+ * form of the command that is no longer recommended or
+ * documented.
*/
char *arg;
@@ -103,8 +103,7 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
arg = Tcl_GetStringFromObj(objv[3], &length);
if ((length != 9) || (strncmp(arg, "nonewline", (size_t) length) != 0)) {
Tcl_AppendResult(interp, "bad argument \"", arg,
- "\": should be \"nonewline\"",
- (char *) NULL);
+ "\": should be \"nonewline\"", (char *) NULL);
return TCL_ERROR;
}
channelId = Tcl_GetString(objv[1]);
@@ -113,34 +112,35 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
newline = 0;
break;
- default: /* puts or puts some bad number of arguments... */
+ default:
+ /* [puts] or [puts some bad number of arguments...] */
Tcl_WrongNumArgs(interp, 1, objv, "?-nonewline? ?channelId? string");
return TCL_ERROR;
}
chan = Tcl_GetChannel(interp, channelId, &mode);
if (chan == (Tcl_Channel) NULL) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", channelId,
- "\" wasn't opened for writing", (char *) NULL);
- return TCL_ERROR;
+ "\" wasn't opened for writing", (char *) NULL);
+ return TCL_ERROR;
}
result = Tcl_WriteObj(chan, string);
if (result < 0) {
- goto error;
+ goto error;
}
if (newline != 0) {
- result = Tcl_WriteChars(chan, "\n", 1);
- if (result < 0) {
- goto error;
- }
+ result = Tcl_WriteChars(chan, "\n", 1);
+ if (result < 0) {
+ goto error;
+ }
}
return TCL_OK;
- error:
+ error:
Tcl_AppendResult(interp, "error writing \"", channelId, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
@@ -151,8 +151,8 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv)
*
* Tcl_FlushObjCmd --
*
- * This procedure is called to process the Tcl "flush" command.
- * See the user documentation for details on what it does.
+ * This procedure is called to process the Tcl "flush" command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -171,7 +171,7 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to flush on. */
+ Tcl_Channel chan; /* The channel to flush on. */
char *channelId;
int mode;
@@ -187,9 +187,9 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv)
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", channelId,
"\" wasn't opened for writing", (char *) NULL);
- return TCL_ERROR;
+ return TCL_ERROR;
}
-
+
if (Tcl_Flush(chan) != TCL_OK) {
Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ",
Tcl_PosixError(interp), (char *) NULL);
@@ -203,8 +203,8 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv)
*
* Tcl_GetsObjCmd --
*
- * This procedure is called to process the Tcl "gets" command.
- * See the user documentation for details on what it does.
+ * This procedure is called to process the Tcl "gets" command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -223,9 +223,9 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- Tcl_Channel chan; /* The channel to read from. */
- int lineLen; /* Length of line just read. */
- int mode; /* Mode in which channel is opened. */
+ Tcl_Channel chan; /* The channel to read from. */
+ int lineLen; /* Length of line just read. */
+ int mode; /* Mode in which channel is opened. */
char *name;
Tcl_Obj *linePtr;
@@ -241,30 +241,30 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv)
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", name,
"\" wasn't opened for reading", (char *) NULL);
- return TCL_ERROR;
+ return TCL_ERROR;
}
linePtr = Tcl_NewObj();
lineLen = Tcl_GetsObj(chan, linePtr);
if (lineLen < 0) {
- if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
+ if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) {
Tcl_DecrRefCount(linePtr);
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading \"", name, "\": ",
Tcl_PosixError(interp), (char *) NULL);
- return TCL_ERROR;
- }
- lineLen = -1;
+ return TCL_ERROR;
+ }
+ lineLen = -1;
}
if (objc == 3) {
if (Tcl_ObjSetVar2(interp, objv[2], NULL, linePtr,
TCL_LEAVE_ERR_MSG) == NULL) {
Tcl_DecrRefCount(linePtr);
- return TCL_ERROR;
- }
+ return TCL_ERROR;
+ }
Tcl_SetObjResult(interp, Tcl_NewIntObj(lineLen));
- return TCL_OK;
+ return TCL_OK;
} else {
Tcl_SetObjResult(interp, linePtr);
}
@@ -276,8 +276,8 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv)
*
* Tcl_ReadObjCmd --
*
- * This procedure is invoked to process the Tcl "read" command.
- * See the user documentation for details on what it does.
+ * This procedure is invoked to process the Tcl "read" command. See the
+ * user documentation for details on what it does.
*
* Results:
* A standard Tcl result.
@@ -307,13 +307,15 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv)
if ((objc != 2) && (objc != 3)) {
Interp *iPtr;
- argerror:
+ argerror:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
+
/*
- * Do not append directly; that makes ensembles using this
- * command as a subcommand produce the wrong message.
+ * Do not append directly; that makes ensembles using this command as
+ * a subcommand produce the wrong message.
*/
+
iPtr->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 (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_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 && i<resLength ; i++) {
ret = Tcl_ListObjAppendElement(interp, resultPtr,
TclFSMakePathRelative(interp, elemsPtr[i], cwd));
}
@@ -1113,18 +1152,18 @@ Tcl_FSMatchInDirectory(interp, resultPtr, pathPtr, pattern, types)
*
* FsAddMountsToGlobResult --
*
- * This routine is used by the globbing code to take the results
- * of a directory listing and add any mounted paths to that
- * listing. This is required so that simple things like
- * 'glob *' merge mounts and listings correctly.
- *
- * Results:
+ * This routine is used by the globbing code to take the results of a
+ * directory listing and add any mounted paths to that listing. This is
+ * required so that simple things like 'glob *' merge mounts and listings
+ * correctly.
+ *
+ * Results:
* None.
*
* Side effects:
* Modifies the resultPtr.
*
- *----------------------------------------------------------------------
+ *----------------------------------------------------------------------
*/
static void
@@ -1151,52 +1190,57 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types)
if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) {
goto endOfMounts;
}
- for (i = 0; i < mLength; i++) {
+ for (i=0 ; i<mLength ; i++) {
Tcl_Obj *mElt;
int j;
int found = 0;
-
+
Tcl_ListObjIndex(NULL, mounts, i, &mElt);
- for (j = 0; j < gLength; j++) {
+ for (j=0 ; j<gLength ; j++) {
Tcl_Obj *gElt;
Tcl_ListObjIndex(NULL, resultPtr, j, &gElt);
if (Tcl_FSEqualPaths(mElt, gElt)) {
found = 1;
if (!dir) {
- /* We don't want to list this */
+ /*
+ * We don't want to list this.
+ */
+
Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL);
gLength--;
}
- /* Break out of for loop */
- break;
+ break; /* Break out of for loop */
}
}
if (!found && dir) {
- int len, mlen;
- CONST char *path;
- CONST char *mount;
-
- /*
- * We know mElt is absolute normalized and lies inside pathPtr,
- * so now we must add to the result the right
- * representation of mElt, i.e. the representation which
- * is relative to pathPtr.
- */
- mount = Tcl_GetStringFromObj(mElt, &mlen);
- path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr),
- &len);
- if (path[len-1] == '/') {
- /* Deal with the root of the volume */
- len--;
- }
- mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len);
- Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
- /*
- * No need to increment gLength, since we
- * don't want to compare mounts against
- * mounts.
+ int len, mlen;
+ CONST char *path;
+ CONST char *mount;
+
+ /*
+ * We know mElt is absolute normalized and lies inside pathPtr, so
+ * now we must add to the result the right representation of mElt,
+ * i.e. the representation which is relative to pathPtr.
+ */
+
+ mount = Tcl_GetStringFromObj(mElt, &mlen);
+ path = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, pathPtr),
+ &len);
+ if (path[len-1] == '/') {
+ /*
+ * Deal with the root of the volume.
+ */
+
+ len--;
+ }
+ mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len);
+ Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
+
+ /*
+ * No need to increment gLength, since we don't want to compare
+ * mounts against mounts.
*/
}
}
@@ -1210,47 +1254,44 @@ FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types)
*
* Tcl_FSMountsChanged --
*
- * Notify the filesystem that the available mounted filesystems
- * (or within any one filesystem type, the number or location of
- * mount points) have changed.
+ * Notify the filesystem that the available mounted filesystems (or
+ * within any one filesystem type, the number or location of mount
+ * points) have changed.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * The global filesystem variable 'theFilesystemEpoch' is
- * incremented. The effect of this is to make all cached
- * path representations invalid. Clearly it should only therefore
- * be called when it is really required! There are a few
- * circumstances when it should be called:
- *
- * (1) when a new filesystem is registered or unregistered.
- * Strictly speaking this is only necessary if the new filesystem
- * accepts file paths as is (normally the filesystem itself is
- * really a shell which hasn't yet had any mount points established
- * and so its 'pathInFilesystem' proc will always fail). However,
- * for safety, Tcl always calls this for you in these circumstances.
- *
- * (2) when additional mount points are established inside any
- * existing filesystem (except the native fs)
- *
- * (3) when any filesystem (except the native fs) changes the list
- * of available volumes.
- *
- * (4) when the mapping from a string representation of a file to
- * a full, normalized path changes. For example, if 'env(HOME)'
- * is modified, then any path containing '~' will map to a different
- * filesystem location. Therefore all such paths need to have
- * their internal representation invalidated.
- *
- * Tcl has no control over (2) and (3), so any registered filesystem
- * must make sure it calls this function when those situations
- * occur.
- *
- * (Note: the reason for the exception in 2,3 for the native
- * filesystem is that the native filesystem by default claims all
- * unknown files even if it really doesn't understand them or if
- * they don't exist).
+ * The global filesystem variable 'theFilesystemEpoch' is incremented.
+ * The effect of this is to make all cached path representations invalid.
+ * Clearly it should only therefore be called when it is really required!
+ * There are a few circumstances when it should be called:
+ *
+ * (1) when a new filesystem is registered or unregistered. Strictly
+ * speaking this is only necessary if the new filesystem accepts file
+ * paths as is (normally the filesystem itself is really a shell which
+ * hasn't yet had any mount points established and so its
+ * 'pathInFilesystem' proc will always fail). However, for safety, Tcl
+ * always calls this for you in these circumstances.
+ *
+ * (2) when additional mount points are established inside any existing
+ * filesystem (except the native fs)
+ *
+ * (3) when any filesystem (except the native fs) changes the list of
+ * available volumes.
+ *
+ * (4) when the mapping from a string representation of a file to a full,
+ * normalized path changes. For example, if 'env(HOME)' is modified, then
+ * any path containing '~' will map to a different filesystem location.
+ * Therefore all such paths need to have their internal representation
+ * invalidated.
+ *
+ * Tcl has no control over (2) and (3), so any registered filesystem must
+ * make sure it calls this function when those situations occur.
+ *
+ * (Note: the reason for the exception in 2,3 for the native filesystem
+ * is that the native filesystem by default claims all unknown files even
+ * if it really doesn't understand them or if they don't exist).
*
*----------------------------------------------------------------------
*/
@@ -1259,16 +1300,19 @@ void
Tcl_FSMountsChanged(fsPtr)
Tcl_Filesystem *fsPtr;
{
- /*
- * We currently don't do anything with this parameter. We
- * could in the future only invalidate files for this filesystem
- * or otherwise take more advanced action.
+ /*
+ * We currently don't do anything with this parameter. We could in the
+ * future only invalidate files for this filesystem or otherwise take more
+ * advanced action.
*/
+
(void)fsPtr;
- /*
- * Increment the filesystem epoch counter, since existing paths
- * might now belong to different filesystems.
+
+ /*
+ * Increment the filesystem epoch counter, since existing paths might now
+ * belong to different filesystems.
*/
+
Tcl_MutexLock(&filesystemMutex);
theFilesystemEpoch++;
Tcl_MutexUnlock(&filesystemMutex);
@@ -1279,16 +1323,16 @@ Tcl_FSMountsChanged(fsPtr)
*
* Tcl_FSData --
*
- * Retrieve the clientData field for the filesystem given,
- * or NULL if that filesystem is not registered.
+ * Retrieve the clientData field for the filesystem given, or NULL if
+ * that filesystem is not registered.
*
* Results:
- * A clientData value, or NULL. Note that if the filesystem
- * was registered with a NULL clientData field, this function
- * will return that NULL value.
+ * A clientData value, or NULL. Note that if the filesystem was
+ * registered with a NULL clientData field, this function will return
+ * that NULL value.
*
* Side effects:
- * None.
+ * None.
*
*----------------------------------------------------------------------
*/
@@ -1301,9 +1345,9 @@ Tcl_FSData(fsPtr)
FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
/*
- * Traverse the list of filesystems look for a particular one.
- * If found, return that filesystem's clientData (originally
- * provided when calling Tcl_FSRegister).
+ * Traverse the list of filesystems look for a particular one. If found,
+ * return that filesystem's clientData (originally provided when calling
+ * Tcl_FSRegister).
*/
while ((retVal == NULL) && (fsRecPtr != NULL)) {
@@ -1321,82 +1365,80 @@ Tcl_FSData(fsPtr)
*
* TclFSNormalizeToUniquePath --
*
- * Description:
- * Takes a path specification containing no ../, ./ sequences,
- * and converts it into a unique path for the given platform.
- * On Unix, this means the path must be free of
- * symbolic links/aliases, and on Windows it means we want the
- * long form, with that long form's case-dependence (which gives
- * us a unique, case-dependent path).
+ * Takes a path specification containing no ../, ./ sequences, and
+ * converts it into a unique path for the given platform. On Unix, this
+ * means the path must be free of symbolic links/aliases, and on Windows
+ * it means we want the long form, with that long form's case-dependence
+ * (which gives us a unique, case-dependent path).
*
* Results:
- * The pathPtr is modified in place. The return value is
- * the last byte offset which was recognised in the path
- * string.
+ * The pathPtr is modified in place. The return value is the last byte
+ * offset which was recognised in the path string.
*
* Side effects:
* None (beyond the memory allocation for the result).
*
* Special notes:
- * If the filesystem-specific normalizePathProcs can re-introduce
- * ../, ./ sequences into the path, then this function will
- * not return the correct result. This may be possible with
- * symbolic links on unix.
- *
- * Important assumption: if startAt is non-zero, it must point
- * to a directory separator that we know exists and is already
- * normalized (so it is important not to point to the char just
- * after the separator).
+ * If the filesystem-specific normalizePathProcs can re-introduce ../, ./
+ * sequences into the path, then this function will not return the
+ * correct result. This may be possible with symbolic links on unix.
+ *
+ * Important assumption: if startAt is non-zero, it must point to a
+ * directory separator that we know exists and is already normalized (so
+ * it is important not to point to the char just after the separator).
+ *
*---------------------------------------------------------------------------
*/
+
int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
- Tcl_Interp *interp; /* Used for error messages. */
- Tcl_Obj *pathPtr; /* The path to normalize in place */
- int startAt; /* Start at this char-offset */
- ClientData *clientDataPtr; /* If we generated a complete
- * normalized path for a given
- * filesystem, we can optionally return
- * an fs-specific clientdata here. */
+ Tcl_Interp *interp; /* Used for error messages. */
+ Tcl_Obj *pathPtr; /* The path to normalize in place */
+ int startAt; /* Start at this char-offset */
+ ClientData *clientDataPtr; /* If we generated a complete normalized path
+ * for a given filesystem, we can optionally
+ * return an fs-specific clientdata here. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/* Ignore this variable */
- (void)clientDataPtr;
-
+ (void) clientDataPtr;
+
/*
- * Call each of the "normalise path" functions in succession. This is
- * a special case, in which if we have a native filesystem handler,
- * we call it first. This is because the root of Tcl's filesystem
- * is always a native filesystem (i.e. '/' on unix is native).
+ * Call each of the "normalise path" functions in succession. This is a
+ * special case, in which if we have a native filesystem handler, we call
+ * it first. This is because the root of Tcl's filesystem is always a
+ * native filesystem (i.e. '/' on unix is native).
*/
firstFsRecPtr = FsGetFirstFilesystem();
- fsRecPtr = firstFsRecPtr;
+ fsRecPtr = firstFsRecPtr;
while (fsRecPtr != NULL) {
- if (fsRecPtr == &nativeFilesystemRecord) {
+ if (fsRecPtr == &nativeFilesystemRecord) {
Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->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 ; i<symc ; i++) {
if (symbols[i] != NULL) {
- *procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
- symbols[i]);
+ *procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
+ symbols[i]);
}
}
- /* Copy this across, since both are equal for the native fs */
+
+ /*
+ * Copy this across, since both are equal for the native fs.
+ */
+
*clientDataPtr = (ClientData)*handlePtr;
- Tcl_ResetResult(interp);
+ Tcl_ResetResult(interp);
return TCL_OK;
}
if (Tcl_GetErrno() != EXDEV) {
- return retVal;
+ return retVal;
}
}
- /*
- * The filesystem doesn't support 'load', so we fall back on
- * the following technique:
+
+ /*
+ * The filesystem doesn't support 'load', so we fall back on the
+ * following technique:
+ *
+ * First check if it is readable -- and exists!
*/
-
- /* First check if it is readable -- and exists! */
+
if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
Tcl_AppendResult(interp, "couldn't load library \"",
- Tcl_GetString(pathPtr), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_GetString(pathPtr), "\": ",
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
-
+
#ifdef TCL_LOAD_FROM_MEMORY
- /*
- * The platform supports loading code from memory, so ask for a
- * buffer of the appropriate size, read the file into it and
- * load the code from the buffer:
+ /*
+ * The platform supports loading code from memory, so ask for a buffer
+ * of the appropriate size, read the file into it and load the code
+ * from the buffer:
*/
+
do {
- int ret, size;
- void *buffer;
- Tcl_StatBuf statBuf;
- Tcl_Channel data;
-
- ret = Tcl_FSStat(pathPtr, &statBuf);
- if (ret < 0) {
- break;
- }
- size = (int) statBuf.st_size;
- /* Tcl_Read takes an int: check that file size isn't wide */
- if (size != (Tcl_WideInt)statBuf.st_size) {
- break;
- }
+ int ret, size;
+ void *buffer;
+ Tcl_StatBuf statBuf;
+ Tcl_Channel data;
+
+ ret = Tcl_FSStat(pathPtr, &statBuf);
+ if (ret < 0) {
+ break;
+ }
+ size = (int) statBuf.st_size;
+
+ /*
+ * Tcl_Read takes an int: check that file size isn't wide.
+ */
+
+ if (size != (Tcl_WideInt) statBuf.st_size) {
+ break;
+ }
data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
- if (!data) {
- break;
- }
- buffer = TclpLoadMemoryGetBuffer(interp, size);
- if (!buffer) {
- Tcl_Close(interp, data);
- break;
- }
- Tcl_SetChannelOption(interp, data, "-translation", "binary");
- ret = Tcl_Read(data, buffer, size);
- Tcl_Close(interp, data);
- ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr);
- if (ret == TCL_OK) {
+ if (!data) {
+ break;
+ }
+ buffer = TclpLoadMemoryGetBuffer(interp, size);
+ if (!buffer) {
+ Tcl_Close(interp, data);
+ break;
+ }
+ Tcl_SetChannelOption(interp, data, "-translation", "binary");
+ ret = Tcl_Read(data, buffer, size);
+ Tcl_Close(interp, data);
+ ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr,
+ unloadProcPtr);
+ if (ret == TCL_OK) {
int i;
if (*handlePtr == NULL) {
break;
}
for (i = 0;i < symc;i++) {
if (symbols[i] != NULL) {
- *procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
- symbols[i]);
+ *procPtrs[i] = TclpFindSymbol(interp, *handlePtr,
+ symbols[i]);
}
}
- *clientDataPtr = (ClientData)*handlePtr;
+ *clientDataPtr = (ClientData) *handlePtr;
return TCL_OK;
}
- } while (0);
+ } while (0);
Tcl_ResetResult(interp);
#endif
- /*
- * Get a temporary filename to use, first to
- * copy the file into, and then to load.
+ /*
+ * Get a temporary filename to use, first to copy the file into, and
+ * then to load.
*/
+
copyToPtr = TclpTempFileName();
if (copyToPtr == NULL) {
Tcl_AppendResult(interp, "couldn't create temporary file: ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
Tcl_IncrRefCount(copyToPtr);
-
+
copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
- /*
- * We already know we can't use Tcl_FSLoadFile from
- * this filesystem, and we must avoid a possible
- * infinite loop. Try to delete the file we
- * probably created, and then exit.
+ /*
+ * We already know we can't use Tcl_FSLoadFile from this
+ * filesystem, and we must avoid a possible infinite loop. Try to
+ * delete the file we probably created, and then exit.
*/
+
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
Tcl_AppendResult(interp, "couldn't load from current filesystem",
- (char *) NULL);
+ (char *) NULL);
return TCL_ERROR;
}
-
+
if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) == TCL_OK) {
Tcl_LoadHandle newLoadHandle = NULL;
ClientData newClientData = NULL;
@@ -3152,15 +3228,13 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
int retVal;
#if !defined(__WIN32__)
- /*
- * Do we need to set appropriate permissions
- * on the file? This may be required on some
- * systems. On Unix we could loop over
- * the file attributes, and set any that are
- * called "-permissions" to 0700. However,
- * we just do this directly, like this:
+ /*
+ * Do we need to set appropriate permissions on the file? This
+ * may be required on some systems. On Unix we could loop over
+ * the file attributes, and set any that are called "-permissions"
+ * to 0700. However, we just do this directly, like this:
*/
-
+
int index;
Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
Tcl_IncrRefCount(perm);
@@ -3170,57 +3244,59 @@ TclLoadFile(interp, pathPtr, symc, symbols, procPtrs,
}
Tcl_DecrRefCount(perm);
#endif
-
- /*
- * We need to reset the result now, because the cross-
- * filesystem copy may have stored the number of bytes
- * in the result
+
+ /*
+ * We need to reset the result now, because the cross- filesystem
+ * copy may have stored the number of bytes in the result.
*/
+
Tcl_ResetResult(interp);
-
- retVal = TclLoadFile(interp, copyToPtr, symc, symbols,
- procPtrs, &newLoadHandle,
- &newClientData,
- &newUnloadProcPtr);
+
+ retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs,
+ &newLoadHandle, &newClientData, &newUnloadProcPtr);
if (retVal != TCL_OK) {
/* The file didn't load successfully */
Tcl_FSDeleteFile(copyToPtr);
Tcl_DecrRefCount(copyToPtr);
return retVal;
}
- /*
- * Try to delete the file immediately -- this is
- * possible in some OSes, and avoids any worries
- * about leaving the copy laying around on exit.
+
+ /*
+ * Try to delete the file immediately - this is possible in some
+ * OSes, and avoids any worries about leaving the copy laying
+ * around on exit.
*/
+
if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
Tcl_DecrRefCount(copyToPtr);
- /*
- * We tell our caller about the real shared
- * library which was loaded. Note that this
- * does mean that the package list maintained
- * by 'load' will store the original (vfs)
- * path alongside the temporary load handle
- * and unload proc ptr.
+
+ /*
+ * We tell our caller about the real shared library which was
+ * loaded. Note that this does mean that the package list
+ * maintained by 'load' will store the original (vfs) path
+ * alongside the temporary load handle and unload proc ptr.
*/
+
(*handlePtr) = newLoadHandle;
(*clientDataPtr) = newClientData;
(*unloadProcPtr) = newUnloadProcPtr;
Tcl_ResetResult(interp);
return TCL_OK;
}
- /*
- * When we unload this file, we need to divert the
- * unloading so we can unload and cleanup the
- * temporary file correctly.
+
+ /*
+ * When we unload this file, we need to divert the unloading so we
+ * can unload and cleanup the temporary file correctly.
*/
- tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
- /*
- * Remember three pieces of information. This allows
- * us to cleanup the diverted load completely, on
- * platforms which allow proper unloading of code.
+ tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));
+
+ /*
+ * Remember three pieces of information. This allows us to
+ * cleanup the diverted load completely, on platforms which allow
+ * proper unloading of code.
*/
+
tvdlPtr->loadHandle = 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 ; i<length ; i++) {
@@ -3593,13 +3607,13 @@ HashObjKey(tablePtr, keyPtr)
* Returns the command specified by the name in a Tcl_Obj.
*
* Results:
- * Returns a token for the command if it is found. Otherwise, if it
- * can't be found or there is an error, returns NULL.
+ * Returns a token for the command if it is found. Otherwise, if it can't
+ * be found or there is an error, returns NULL.
*
* Side effects:
- * May update the internal representation for the object, caching
- * the command reference so that the next time this procedure is
- * called with the same object, the command can be found quickly.
+ * May update the internal representation for the object, caching the
+ * command reference so that the next time this procedure is called with
+ * the same object, the command can be found quickly.
*
*----------------------------------------------------------------------
*/
@@ -3608,11 +3622,11 @@ Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to resolve the
* command and to report errors. */
- register Tcl_Obj *objPtr; /* The object containing the command's
- * name. If the name starts with "::", will
- * be looked up in global namespace. Else,
- * looked up first in the current namespace,
- * then in global namespace. */
+ register Tcl_Obj *objPtr; /* The object containing the command's name.
+ * If the name starts with "::", will be
+ * looked up in global namespace. Else, looked
+ * up first in the current namespace, then in
+ * global namespace. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
@@ -3623,11 +3637,11 @@ Tcl_GetCommandFromObj(interp, objPtr)
char *name;
/*
- * 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]
+ * 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]
*/
savedFramePtr = iPtr->varFramePtr;
@@ -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:
+ */
generated by cgit v0.12 at 2024-11-09 10:33:17 (GMT)