summaryrefslogtreecommitdiffstats
path: root/generic/tclBinary.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBinary.c')
-rw-r--r--generic/tclBinary.c1676
1 files changed, 829 insertions, 847 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:
+ */