diff options
Diffstat (limited to 'generic/tclBinary.c')
| -rw-r--r-- | generic/tclBinary.c | 3043 |
1 files changed, 941 insertions, 2102 deletions
diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 570f4d5..68289f2 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -4,18 +4,17 @@ * This file contains the implementation of the "binary" Tcl built-in * command and the Tcl binary data object. * - * Copyright © 1997 Sun Microsystems, Inc. - * Copyright © 1998-1999 Scriptics Corporation. + * Copyright (c) 1997 by 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. */ #include "tclInt.h" -#include "tclTomMath.h" +#include "tommath.h" #include <math.h> -#include <assert.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -26,7 +25,7 @@ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* - * The following flags may be OR'ed together and returned by GetFormatSpec + * The following flags may be ORed together and returned by GetFormatSpec */ #define BINARY_SIGNED 0 /* Field to be read as signed data */ @@ -37,7 +36,7 @@ * 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 practice when + * 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 @@ -57,14 +56,11 @@ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); -static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); -static int GetFormatSpec(const char **formatPtr, char *cmdPtr, - Tcl_Size *countPtr, int *flagsPtr); +static int GetFormatSpec(char **formatPtr, char *cmdPtr, + int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); static int SetByteArrayFromAny(Tcl_Interp *interp, @@ -74,149 +70,37 @@ static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, unsigned int length, int type); -/* Binary ensemble commands */ -static Tcl_ObjCmdProc BinaryFormatCmd; -static Tcl_ObjCmdProc BinaryScanCmd; -/* Binary encoding sub-ensemble commands */ -static Tcl_ObjCmdProc BinaryEncodeHex; -static Tcl_ObjCmdProc BinaryDecodeHex; -static Tcl_ObjCmdProc BinaryEncode64; -static Tcl_ObjCmdProc BinaryDecode64; -static Tcl_ObjCmdProc BinaryEncodeUu; -static Tcl_ObjCmdProc BinaryDecodeUu; - -/* - * The following tables are used by the binary encoders - */ - -static const char HexDigits[16] = { - '0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', 'a', 'b', 'c', 'd', 'e', 'f' -}; - -static const char UueDigits[65] = { - '`', '!', '"', '#', '$', '%', '&', '\'', - '(', ')', '*', '+', ',', '-', '.', '/', - '0', '1', '2', '3', '4', '5', '6', '7', - '8', '9', ':', ';', '<', '=', '>', '?', - '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', - 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', - 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', - 'X', 'Y', 'Z', '[', '\\',']', '^', '_', - '`' -}; - -static const char B64Digits[65] = { - 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', - 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', - 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', - 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', - 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', - 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', - 'w', 'x', 'y', 'z', '0', '1', '2', '3', - '4', '5', '6', '7', '8', '9', '+', '/', - '=' -}; - -/* - * How to construct the ensembles. - */ - -static const EnsembleImplMap binaryMap[] = { - { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, - { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, - { "encode", NULL, NULL, NULL, NULL, 0 }, - { "decode", NULL, NULL, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, - { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, - { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; -static const EnsembleImplMap decodeMap[] = { - { "hex", BinaryDecodeHex, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "uuencode", BinaryDecodeUu, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { "base64", BinaryDecode64, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, - { NULL, NULL, NULL, NULL, NULL, 0 } -}; /* - * The following Tcl_ObjType represents an array of bytes. The intent is to - * allow arbitrary binary data to pass through Tcl as a Tcl value without loss - * or damage. Such values are useful for things like encoded strings or Tk - * images to name just two. - * - * It's strange to have two Tcl_ObjTypes in place for this task when one would - * do, so a bit of detail and history will aid understanding. - * - * A bytearray is an ordered sequence of bytes. Each byte is an integer value - * in the range [0-255]. To be a Tcl value type, we need a way to encode each - * value in the value set as a Tcl string. A simple encoding is to - * represent each byte value as the same codepoint value. A bytearray of N - * bytes is encoded into a Tcl string of N characters where the codepoint of - * each character is the value of corresponding byte. This approach creates a - * one-to-one map between all bytearray values and a subset of Tcl string - * values. - * - * When converting a Tcl string value to the bytearray internal rep, the - * question arises what to do with strings outside that subset? That is, - * those Tcl strings containing at least one codepoint greater than 255? The - * obviously correct answer is to raise an error! That string value does not - * represent any valid bytearray value. - * - * Unfortunately this was not the path taken by the authors of the original - * tclByteArrayType. They chose to accept all Tcl string values as acceptable - * string encodings of the bytearray values that result from masking away the - * high bits of any codepoint value at all. This meant that every bytearray - * value had multiple accepted string representations. - * - * The implications of this choice are truly ugly, and motivated the proposal - * of TIP 568 to migrate away from it and to the more sensible design where - * each bytearray value has only one string representation. Full details are - * recorded in that TIP for those who seek them. - * - * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation - * of bytearrays. Any Tcl value with the type properByteArrayType can have - * its bytearray value fetched and used with confidence that acting on that - * value is equivalent to acting on the true Tcl string value. This still - * implies a side testing burden -- past mistakes will not let us avoid that - * immediately, but it is at least a conventional test of type, and can be - * implemented entirely by examining the objPtr fields, with no need to query - * the internalrep, as a canonical flag would require. This benefit is made - * available to extensions through the public routine Tcl_GetBytesFromObj(), - * first available in Tcl 8.7. - * - * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() - * must continue to follow their documented behavior through the 8.* series of - * releases. To support that legacy operation, we need a mechanism to retain - * compatibility with the deployed callers of the broken interface. That's - * what the retained "tclByteArrayType" provides. In those unusual - * circumstances where we convert an invalid bytearray value to a bytearray - * type, it is to this legacy type. Essentially any time this legacy type - * shows up, it's a signal of a bug being ignored. - * - * In Tcl 9, the incompatibility in the behavior of these public routines - * has been approved, and the legacy internal rep is no longer retained. - * The internal changes seen below are the limit of what can be done - * in a Tcl 8.* release. They provide a great expansion of the histories - * over which bytearray values can be useful. + * 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. + * + * 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. + * + * 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. */ -static const Tcl_ObjType properByteArrayType = { - "bytearray", - FreeProperByteArrayInternalRep, - DupProperByteArrayInternalRep, - UpdateStringOfByteArray, - NULL -}; - -const Tcl_ObjType tclByteArrayType = { +Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - NULL, + UpdateStringOfByteArray, SetByteArrayFromAny }; @@ -228,31 +112,22 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - unsigned int bad; /* Index of first character that is a nonbyte. - * If all characters are bytes, bad = used. */ - unsigned int used; /* The number of bytes used in the byte - * array. Must be <= allocated. The bytes - * used to store the value are indexed from - * 0 to used-1. */ - unsigned int allocated; /* The number of bytes of space allocated. */ - unsigned char bytes[TCLFLEXARRAY]; - /* The array of bytes. The actual size of this - * field is stored in the 'allocated' field + int used; /* The number of bytes used in the byte + * array. */ + int allocated; /* The amount of space actually allocated + * minus 1 byte. */ + unsigned char bytes[4]; /* The array of bytes. The actual size of this + * field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ - (offsetof(ByteArray, bytes) + (len)) -#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) -#define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) + ((unsigned) (sizeof(ByteArray) - 4 + (len))) +#define GET_BYTEARRAY(objPtr) \ + ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_BYTEARRAY(objPtr, baPtr) \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (VOID *) (baPtr) -int -TclIsPureByteArray( - Tcl_Obj * objPtr) -{ - return TclHasInternalRep(objPtr, &properByteArrayType); -} /* *---------------------------------------------------------------------- @@ -263,7 +138,7 @@ TclIsPureByteArray( * from the given array of bytes. * * Results: - * The newly created object is returned. This object has no initial + * 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: @@ -272,25 +147,35 @@ TclIsPureByteArray( *---------------------------------------------------------------------- */ +#ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj Tcl_Obj * Tcl_NewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - Tcl_Size numBytes) /* Number of bytes in the array, - * must be >= 0. */ + int length) /* Length of the array of bytes, which must be + * >= 0. */ { -#ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, numBytes, "unknown", 0); + return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); +} + #else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewByteArrayObj( + 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; TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, numBytes); + Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; -#endif /* TCL_MEM_DEBUG */ } +#endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- @@ -308,7 +193,7 @@ Tcl_NewByteArrayObj( * result of calling Tcl_NewByteArrayObj. * * Results: - * The newly created object is returned. This object has no initial + * 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: @@ -318,12 +203,13 @@ Tcl_NewByteArrayObj( */ #ifdef TCL_MEM_DEBUG + Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - Tcl_Size numBytes, /* Number of bytes in the array, - * must be >= 0. */ + 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 @@ -332,23 +218,27 @@ Tcl_DbNewByteArrayObj( Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, numBytes); + Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; } + #else /* if not TCL_MEM_DEBUG */ + Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - int numBytes, /* Number of bytes in the array, - * must be >= 0. */ - TCL_UNUSED(const char *) /*file*/, - TCL_UNUSED(int) /*line*/) + 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. */ { - return Tcl_NewByteArrayObj(bytes, numBytes); + return Tcl_NewByteArrayObj(bytes, length); } #endif /* TCL_MEM_DEBUG */ - + /* *--------------------------------------------------------------------------- * @@ -370,88 +260,31 @@ Tcl_DbNewByteArrayObj( void Tcl_SetByteArrayObj( Tcl_Obj *objPtr, /* Object to initialize as a ByteArray. */ - const unsigned char *bytes, /* The array of bytes to use as the new value. - * May be NULL even if numBytes > 0. */ - Tcl_Size numBytes) /* Number of bytes in the array, - * must be >= 0 */ + 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. */ { ByteArray *byteArrayPtr; - Tcl_ObjInternalRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } + TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); - assert(numBytes >= 0); - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes)); - byteArrayPtr->bad = numBytes; - byteArrayPtr->used = numBytes; - byteArrayPtr->allocated = numBytes; - - if ((bytes != NULL) && (numBytes > 0)) { - memcpy(byteArrayPtr->bytes, bytes, numBytes); - } - SET_BYTEARRAY(&ir, byteArrayPtr); - - Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetBytesFromObj -- - * - * Attempt to extract the value from objPtr in the representation - * of a byte sequence. On success return the extracted byte sequence. - * On failure, return NULL and record error message and code in - * interp (if not NULL). - * - * Results: - * NULL or pointer to array of bytes representing the ByteArray object. - * Writes number of bytes in array to *numBytesPtr. - * - *---------------------------------------------------------------------- - */ - -unsigned char * -Tcl_GetBytesFromObj( - Tcl_Interp *interp, /* For error reporting */ - Tcl_Obj *objPtr, /* Value to extract from */ - Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ -{ - ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr - = TclFetchInternalRep(objPtr, &properByteArrayType); - - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - if (interp) { - const char *nonbyte; - int ucs4; - - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - baPtr = GET_BYTEARRAY(irPtr); - nonbyte = TclUtfAtIndex(Tcl_GetString(objPtr), baPtr->bad); - TclUtfToUniChar(nonbyte, &ucs4); - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected byte sequence but character %d " - "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL); - } - return NULL; - } + if (length < 0) { + length = 0; } - baPtr = GET_BYTEARRAY(irPtr); + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + byteArrayPtr->used = length; + byteArrayPtr->allocated = length; - if (numBytesPtr != NULL) { - *numBytesPtr = baPtr->used; + if ((bytes != NULL) && (length > 0)) { + memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - return baPtr->bytes; + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } /* @@ -475,24 +308,18 @@ Tcl_GetBytesFromObj( unsigned char * Tcl_GetByteArrayFromObj( Tcl_Obj *objPtr, /* The ByteArray object. */ - Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes - * in the array here */ + int *lengthPtr) /* If non-NULL, filled with length of the + * array of bytes in the ByteArray object. */ { ByteArray *baPtr; - const Tcl_ObjInternalRep *irPtr; - unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); - if (result) { - return result; + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); } + baPtr = GET_BYTEARRAY(objPtr); - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - assert(irPtr != NULL); - - baPtr = GET_BYTEARRAY(irPtr); - - if (numBytesPtr != NULL) { - *numBytesPtr = baPtr->used; + if (lengthPtr != NULL) { + *lengthPtr = baPtr->used; } return (unsigned char *) baPtr->bytes; } @@ -522,44 +349,26 @@ Tcl_GetByteArrayFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - Tcl_Size numBytes) /* Number of bytes in resized array */ + int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; - unsigned newLength; - Tcl_ObjInternalRep *irPtr; - - assert(numBytes >= 0); - newLength = (unsigned int)numBytes; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - } - } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); } - /* Note that during truncation, the implementation does not free - * memory that is no longer needed. */ - - byteArrayPtr = GET_BYTEARRAY(irPtr); - if (newLength > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); - byteArrayPtr->allocated = newLength; - SET_BYTEARRAY(irPtr, byteArrayPtr); + byteArrayPtr = GET_BYTEARRAY(objPtr); + if (length > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *) ckrealloc( + (char *) byteArrayPtr, BYTEARRAY_SIZE(length)); + byteArrayPtr->allocated = length; + SET_BYTEARRAY(objPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; - byteArrayPtr->bad = newLength; - byteArrayPtr->used = newLength; + byteArrayPtr->used = length; return byteArrayPtr->bytes; } @@ -581,51 +390,32 @@ Tcl_SetByteArrayLength( static int SetByteArrayFromAny( - TCL_UNUSED(Tcl_Interp *), + Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length, bad; - const char *src, *srcEnd; + int length; + char *src, *srcEnd; unsigned char *dst; - Tcl_UniChar ch = 0; ByteArray *byteArrayPtr; - Tcl_ObjInternalRep ir; - - if (TclHasInternalRep(objPtr, &properByteArrayType)) { - return TCL_OK; - } - if (TclHasInternalRep(objPtr, &tclByteArrayType)) { - return TCL_OK; - } + Tcl_UniChar ch; - src = TclGetStringFromObj(objPtr, &length); - bad = length; - srcEnd = src + length; + if (objPtr->typePtr != &tclByteArrayType) { + src = TclGetStringFromObj(objPtr, &length); + srcEnd = src + length; - /* Note the allocation is over-sized, possibly by a factor of four, - * or even a factor of two with a proper byte array value. */ - - byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); - if ((bad == length) && (ch > 255)) { - bad = dst - byteArrayPtr->bytes; + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = (unsigned char) ch; } - *dst++ = UCHAR(ch); - } - SET_BYTEARRAY(&ir, byteArrayPtr); - byteArrayPtr->allocated = length; - byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; - if (bad == length) { - byteArrayPtr->bad = byteArrayPtr->used; - Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); - } else { - byteArrayPtr->bad = bad; - Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir); + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); } - return TCL_OK; } @@ -650,14 +440,8 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType))); -} - -static void -FreeProperByteArrayInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); + ckfree((char *) GET_BYTEARRAY(objPtr)); + objPtr->typePtr = NULL; } /* @@ -682,43 +466,19 @@ DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - unsigned int length; + int length; ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjInternalRep ir; - srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType)); + srcArrayPtr = GET_BYTEARRAY(srcPtr); length = srcArrayPtr->used; - copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->bad = srcArrayPtr->bad; + copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); + SET_BYTEARRAY(copyPtr, copyArrayPtr); - SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir); -} - -static void -DupProperByteArrayInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - unsigned int length; - ByteArray *srcArrayPtr, *copyArrayPtr; - Tcl_ObjInternalRep ir; - - srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType)); - length = srcArrayPtr->used; - - copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->bad = length; - copyArrayPtr->used = length; - copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); - - SET_BYTEARRAY(&ir, copyArrayPtr); - Tcl_StoreInternalRep(copyPtr, &properByteArrayType, &ir); + copyPtr->typePtr = &tclByteArrayType; } /* @@ -726,7 +486,9 @@ DupProperByteArrayInternalRep( * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. + * 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. @@ -735,6 +497,9 @@ DupProperByteArrayInternalRep( * 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. + * *---------------------------------------------------------------------- */ @@ -743,36 +508,41 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); - unsigned char *src = byteArrayPtr->bytes; - unsigned int i, length = byteArrayPtr->used; - unsigned int size = length; + int i, length, size; + unsigned char *src; + char *dst; + ByteArray *byteArrayPtr; + + byteArrayPtr = GET_BYTEARRAY(objPtr); + src = byteArrayPtr->bytes; + length = byteArrayPtr->used; /* * How much space will string rep need? */ - for (i = 0; i < length && size <= INT_MAX; i++) { + size = length; + for (i = 0; i < length && size >= 0; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size > INT_MAX) { + if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - if (size == length) { - char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); + dst = (char *) ckalloc((unsigned) (size + 1)); + objPtr->bytes = dst; + objPtr->length = size; - TclOOM(dst, size); + if (size == length) { + memcpy(dst, src, (size_t) size); + dst[size] = '\0'; } else { - char *dst = Tcl_InitStringRep(objPtr, NULL, size); - - TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } + *dst = '\0'; } } @@ -795,15 +565,15 @@ UpdateStringOfByteArray( *---------------------------------------------------------------------- */ +#define TCL_MIN_GROWTH 1024 void TclAppendBytesToByteArray( Tcl_Obj *objPtr, const unsigned char *bytes, - Tcl_Size len) + int len) { ByteArray *byteArrayPtr; - unsigned int length, needed; - Tcl_ObjInternalRep *irPtr; + int needed; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -813,117 +583,67 @@ TclAppendBytesToByteArray( "TclAppendBytesToByteArray"); } if (len == 0) { - /* - * Append zero bytes is a no-op. - */ - + /* Append zero bytes is a no-op. */ return; } - - length = (unsigned int) len; - - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - if (irPtr == NULL) { - SetByteArrayFromAny(NULL, objPtr); - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); - if (irPtr == NULL) { - irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); - } - } + if (objPtr->typePtr != &tclByteArrayType) { + SetByteArrayFromAny(NULL, objPtr); } - byteArrayPtr = GET_BYTEARRAY(irPtr); + byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > INT_MAX - byteArrayPtr->used) { + if (len > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - needed = byteArrayPtr->used + length; + needed = byteArrayPtr->used + len; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - unsigned int attempt; + int attempt; if (needed <= INT_MAX/2) { - /* - * Try to allocate double the total space that is needed. - */ - + /* Try to allocate double the total space that is needed. */ attempt = 2 * needed; - ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { - /* - * Try to allocate double the increment that is needed (plus). - */ - + /* Try to allocate double the increment that is needed (plus). */ unsigned int limit = INT_MAX - needed; - unsigned int extra = length + TCL_MIN_GROWTH; + unsigned int extra = len + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; - ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) attemptckrealloc((void *) byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } if (ptr == NULL) { - /* - * Last chance: Try to allocate exactly what is needed. - */ - + /* Last chance: Try to allocate exactly what is needed. */ attempt = needed; - ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + ptr = (ByteArray *) ckrealloc((void *)byteArrayPtr, + BYTEARRAY_SIZE(attempt)); } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(irPtr, byteArrayPtr); + SET_BYTEARRAY(objPtr, byteArrayPtr); } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); } - byteArrayPtr->used += length; + byteArrayPtr->used += len; TclInvalidateStringRep(objPtr); - objPtr->typePtr = &properByteArrayType; } /* *---------------------------------------------------------------------- * - * TclInitBinaryCmd -- + * Tcl_BinaryObjCmd -- * - * This function is called to create the "binary" Tcl command. See the - * user documentation for details on what it does. - * - * Results: - * A command token for the new command. - * - * Side effects: - * Creates a new binary command as a mapped ensemble. - * - *---------------------------------------------------------------------- - */ - -Tcl_Command -TclInitBinaryCmd( - Tcl_Interp *interp) -{ - Tcl_Command binaryEnsemble; - - binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap); - TclMakeEnsemble(interp, "binary encode", encodeMap); - TclMakeEnsemble(interp, "binary decode", decodeMap); - return binaryEnsemble; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryFormatCmd -- - * - * This procedure implements the "binary format" Tcl command. + * This procedure implements the "binary" Tcl command. * * Results: * A standard Tcl result. @@ -934,9 +654,9 @@ TclInitBinaryCmd( *---------------------------------------------------------------------- */ -static int -BinaryFormatCmd( - TCL_UNUSED(void *), +int +Tcl_BinaryObjCmd( + ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -945,10 +665,10 @@ BinaryFormatCmd( int value = 0; /* Current integer value to be packed. * Initialized to avoid compiler warning. */ char cmd; /* Current format character. */ - Tcl_Size count; /* Count associated with current format + int count; /* Count associated with current format * character. */ int flags; /* Format field flags */ - const char *format; /* Pointer to current position in format + char *format; /* Pointer to current position in format * string. */ Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ unsigned char *buffer; /* Start of result buffer. */ @@ -956,852 +676,797 @@ BinaryFormatCmd( unsigned char *maxPos; /* Greatest position within result buffer that * cursor has visited.*/ const char *errorString; - const char *errorValue, *str; - Tcl_Size offset, size, length; + char *errorValue, *str; + int offset, size, length, index; + static const char *options[] = { + "format", "scan", NULL + }; + enum options { + BINARY_FORMAT, BINARY_SCAN + }; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "option ?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. - */ + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } - format = TclGetString(objv[1]); - arg = 2; - offset = 0; - length = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; + switch ((enum options) index) { + case BINARY_FORMAT: + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); + return TCL_ERROR; } - 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; - } + /* + * 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. + */ - /* - * 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. - */ + format = TclGetString(objv[2]); + arg = 3; + offset = 0; + length = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + 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. + */ - if (count == BINARY_NOCOUNT) { + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } arg++; - count = 1; - } else { - Tcl_Size listc; - Tcl_Obj **listv; + 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; + } /* - * The macro evals its args more than once: avoid arg++ + * 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 (TclListObjLength(interp, objv[arg], &listc - ) != TCL_OK) { - return TCL_ERROR; + if (count == BINARY_NOCOUNT) { + arg++; + count = 1; + } else { + int listc; + Tcl_Obj **listv; + + /* The macro evals its args more than once: avoid arg++ */ + if (TclListObjGetElements(interp, objv[arg], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; + } + arg++; + + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + Tcl_AppendResult(interp, + "number of elements in list does not match count", + NULL); + return TCL_ERROR; + } } + offset += count*size; + break; + case 'x': if (count == BINARY_ALL) { - count = listc; - } else if (count > listc) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "number of elements in list does not match count", - -1)); + Tcl_AppendResult(interp, + "cannot use \"*\" in format string with \"x\"", + NULL); return TCL_ERROR; + } else if (count == BINARY_NOCOUNT) { + count = 1; } - if (TclListObjGetElements(interp, objv[arg], &listc, - &listv) != TCL_OK) { - return TCL_ERROR; + offset += count; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; } - arg++; - } - offset += count*size; - break; - - case 'x': - if (count == BINARY_ALL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot use \"*\" in format string with \"x\"", -1)); - 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; + 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; } - break; - default: - errorString = str; - goto badField; } - } - if (offset > length) { - length = offset; - } - if (length == 0) { - return TCL_OK; - } + if (offset > length) { + length = offset; + } + if (length == 0) { + return TCL_OK; + } - /* - * Prepare the result object by preallocating the calculated number of - * bytes and filling with nulls. - */ + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. + */ - TclNewObj(resultPtr); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, length); + resultPtr = Tcl_NewObj(); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset(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. - */ + /* + * 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 = 2; - format = TclGetString(objv[1]); - cursor = buffer; - maxPos = cursor; - while (*format != 0) { - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; - } - if ((count == 0) && (cmd != '@')) { - if (cmd != 'x') { - arg++; - } - continue; - } - 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(cursor, bytes, count); - } else { - memcpy(cursor, bytes, length); - memset(cursor + length, pad, count - length); + arg = 3; + format = TclGetString(objv[2]); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; } - cursor += count; - break; - } - case 'b': - case 'B': { - unsigned char *last; - - str = TclGetStringFromObj(objv[arg], &length); - arg++; - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; + if ((count == 0) && (cmd != '@')) { + if (cmd != 'x') { + 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; + } + if (length >= count) { + memcpy(cursor, bytes, (size_t) count); + } else { + memcpy(cursor, bytes, (size_t) length); + memset(cursor + length, pad, (size_t) (count - length)); + } + cursor += count; + break; } - 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; - Tcl_DecrRefCount(resultPtr); - goto badValue; + case 'b': + case 'B': { + unsigned char *last; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 7) / 8); + if (count > length) { + count = length; + } + 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; + Tcl_DecrRefCount(resultPtr); + goto badValue; + } + if (((offset + 1) % 8) == 0) { + *cursor++ = (unsigned char) value; + value = 0; + } } - if (((offset + 1) % 8) == 0) { - *cursor++ = UCHAR(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; + Tcl_DecrRefCount(resultPtr); + goto badValue; + } + if (!((offset + 1) % 8)) { + *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; - Tcl_DecrRefCount(resultPtr); - goto badValue; - } - if (!((offset + 1) % 8)) { - *cursor++ = UCHAR(value); - value = 0; + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); } + *cursor++ = (unsigned char) value; } - } - if ((offset % 8) != 0) { - if (cmd == 'B') { - value <<= 8 - (offset % 8); - } else { - value >>= 8 - (offset % 8); + while (cursor < last) { + *cursor++ = '\0'; } - *cursor++ = UCHAR(value); - } - while (cursor < last) { - *cursor++ = '\0'; - } - break; - } - case 'h': - case 'H': { - unsigned char *last; - int c; - - str = TclGetStringFromObj(objv[arg], &length); - arg++; - if (count == BINARY_ALL) { - count = length; - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - last = cursor + ((count + 1) / 2); - if (count > length) { - count = length; + break; } - value = 0; - errorString = "hexadecimal"; - if (cmd == 'H') { - for (offset = 0; offset < count; offset++) { - value <<= 4; - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - Tcl_DecrRefCount(resultPtr); - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; + case 'h': + case 'H': { + unsigned char *last; + int c; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + 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; + Tcl_DecrRefCount(resultPtr); + 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; + } } - if (c > 16) { - c += ('A' - 'a'); + } else { + for (offset = 0; offset < count; offset++) { + value >>= 4; + + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ + errorValue = str; + Tcl_DecrRefCount(resultPtr); + 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; + } } - value |= (c & 0xF); - if (offset % 2) { - *cursor++ = (char) value; - value = 0; + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; } + *cursor++ = (unsigned char) value; } - } else { - for (offset = 0; offset < count; offset++) { - value >>= 4; - if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ - errorValue = str; - Tcl_DecrRefCount(resultPtr); - goto badValue; - } - c = str[offset] - '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + 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 { + TclListObjGetElements(interp, objv[arg], &listc, &listv); + if (count == BINARY_ALL) { + count = listc; } - value |= ((c << 4) & 0xF0); - if (offset % 2) { - *cursor++ = UCHAR(value & 0xFF); - value = 0; + } + arg++; + for (i = 0; i < count; i++) { + if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { + Tcl_DecrRefCount(resultPtr); + return TCL_ERROR; } } + break; } - if (offset % 2) { - if (cmd == 'H') { - value <<= 4; + 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 { - value >>= 4; + cursor -= count; } - *cursor++ = UCHAR(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': { - Tcl_Size 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 { - TclListObjGetElements(interp, objv[arg], &listc, &listv); - if (count == BINARY_ALL) { - count = listc; + break; + case '@': + if (cursor > maxPos) { + maxPos = cursor; } - } - arg++; - for (i = 0; i < count; i++) { - if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) { - Tcl_DecrRefCount(resultPtr); - return TCL_ERROR; + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; } + break; } - break; - } - case 'x': - if (count == BINARY_NOCOUNT) { - count = 1; - } - memset(cursor, 0, 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); - return TCL_OK; - - badValue: - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected %s string but got \"%s\" instead", - errorString, errorValue)); - return TCL_ERROR; - - badCount: - errorString = "missing count for \"@\" field specifier"; - goto error; - - badIndex: - errorString = "not enough arguments for all format specifiers"; - goto error; - - badField: - { - Tcl_UniChar ch = 0; - char buf[5] = ""; - - TclUtfToUniChar(errorString, &ch); - buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad field specifier \"%s\"", buf)); - return TCL_ERROR; - } - - error: - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryScanCmd -- - * - * This procedure implements the "binary scan" Tcl command. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -BinaryScanCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int arg; /* Index of next argument to consume. */ - int value = 0; /* Current integer value to be packed. - * Initialized to avoid compiler warning. */ - char cmd; /* Current format character. */ - Tcl_Size count; /* Count associated with current format - * character. */ - int flags; /* Format field flags */ - const char *format; /* Pointer to current position in format - * string. */ - Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ - unsigned char *buffer; /* Start of result buffer. */ - const char *errorString; - const char *str; - Tcl_Size offset, size, length, i; - - Tcl_Obj *valuePtr, *elementPtr; - Tcl_HashTable numberCacheHash; - Tcl_HashTable *numberCachePtr; - - if (objc < 3) { - Tcl_WrongNumArgs(interp, 1, objv, - "value formatString ?varName ...?"); - return TCL_ERROR; - } - numberCachePtr = &numberCacheHash; - Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[1], &length); - format = TclGetString(objv[2]); - arg = 3; - offset = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - goto done; + 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; } - switch (cmd) { - case 'a': - case 'A': - case 'C': { - unsigned char *src; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = length - offset; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[2], &length); + format = TclGetString(objv[3]); + cursor = buffer; + arg = 4; + offset = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + goto done; + } + switch (cmd) { + case 'a': + case 'A': { + unsigned char *src; + + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; } - if (count > (length - offset)) { - goto done; + 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; - /* - * Apply C string semantics or trim trailing - * nulls and spaces, if necessary. - */ + /* + * Trim trailing nulls and spaces, if necessary. + */ - if (cmd == 'C') { - for (i = 0; i < size; i++) { - if (src[i] == '\0') { - size = i; - break; - } - } - } else if (cmd == 'A') { - while (size > 0) { - if (src[size - 1] != '\0' && src[size - 1] != ' ') { - break; + if (cmd == 'A') { + while (size > 0) { + if (src[size-1] != '\0' && src[size-1] != ' ') { + break; + } + size--; } - size--; } - } - /* - * 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. - */ + /* + * 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__); + valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__); #else - valuePtr = Tcl_NewByteArrayObj(src, size); + 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); - 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; - } - if (count > (length - offset) * 8) { - goto done; + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; } + offset += count; + break; } - src = buffer + offset; - TclNewObj(valuePtr); - Tcl_SetObjLength(valuePtr, count); - dest = TclGetString(valuePtr); + case 'b': + case 'B': { + unsigned char *src; + char *dest; - if (cmd == 'b') { - for (i = 0; i < count; i++) { - if (i % 8) { - value >>= 1; - } else { - value = *src++; + 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; } - *dest++ = (char) ((value & 1) ? '1' : '0'); } - } else { - for (i = 0; i < count; i++) { - if (i % 8) { - value <<= 1; - } else { - value = *src++; + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = TclGetString(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'); } - *dest++ = (char) ((value & 0x80) ? '1' : '0'); } - } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - return TCL_ERROR; - } - offset += (count + 7) / 8; - break; - } - case 'h': - case 'H': { - char *dest; - unsigned char *src; - static const 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; - } - if (count > (length - offset)*2) { - goto done; + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; } + offset += (count + 7) / 8; + break; } - src = buffer + offset; - TclNewObj(valuePtr); - Tcl_SetObjLength(valuePtr, count); - dest = TclGetString(valuePtr); + case 'h': + case 'H': { + char *dest; + unsigned char *src; + int i; + static const char hexdigit[] = "0123456789abcdef"; - if (cmd == 'h') { - for (i = 0; i < count; i++) { - if (i % 2) { - value >>= 4; - } else { - value = *src++; + if (arg >= objc) { + DeleteScanNumberCache(numberCachePtr); + goto badIndex; + } + if (count == BINARY_ALL) { + count = (length - offset)*2; + } else { + if (count == BINARY_NOCOUNT) { + count = 1; + } + if (count > (length - offset)*2) { + goto done; } - *dest++ = hexdigit[value & 0xF]; } - } else { - for (i = 0; i < count; i++) { - if (i % 2) { - value <<= 4; - } else { - value = *src++; + src = buffer + offset; + valuePtr = Tcl_NewObj(); + Tcl_SetObjLength(valuePtr, count); + dest = TclGetString(valuePtr); + + if (cmd == 'h') { + for (i = 0; i < count; i++) { + if (i % 2) { + value >>= 4; + } else { + value = *src++; + } + *dest++ = hexdigit[value & 0xf]; + } + } else { + for (i = 0; i < count; i++) { + if (i % 2) { + value <<= 4; + } else { + value = *src++; + } + *dest++ = hexdigit[(value >> 4) & 0xf]; } - *dest++ = hexdigit[(value >> 4) & 0xF]; } - } - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - return TCL_ERROR; + resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, + TCL_LEAVE_ERR_MSG); + arg++; + if (resultPtr == NULL) { + DeleteScanNumberCache(numberCachePtr); + return TCL_ERROR; + } + offset += (count + 1) / 2; + break; } - 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; + 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; + } + valuePtr = ScanNumber(buffer+offset, cmd, flags, + &numberCachePtr); + offset += size; + } 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, flags, + &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); + return TCL_ERROR; + } + break; } - if (count == BINARY_NOCOUNT) { - if (length < (size + offset)) { - goto done; + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; } - valuePtr = ScanNumber(buffer+offset, cmd, flags, - &numberCachePtr); - offset += size; - } else { - if (count == BINARY_ALL) { - count = (length - offset) / size; + if ((count == BINARY_ALL) || (count > (length - offset))) { + offset = length; + } else { + offset += count; } - if ((length - offset) < (count * size)) { - goto done; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; } - TclNewObj(valuePtr); - src = buffer + offset; - for (i = 0; i < count; i++) { - elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr); - src += size; - Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); + if ((count == BINARY_ALL) || (count > offset)) { + offset = 0; + } else { + offset -= count; } - offset += count * size; - } - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - 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) { + 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); - goto badCount; - } - if ((count == BINARY_ALL) || (count > length)) { - offset = length; - } else { - offset = count; + errorString = str; + goto badField; } - break; - default: - DeleteScanNumberCache(numberCachePtr); - errorString = str; - goto badField; } - } - - /* - * Set the result to the last position of the cursor. - */ - done: - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3)); - DeleteScanNumberCache(numberCachePtr); + /* + * Set the result to the last position of the cursor. + */ + done: + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); + DeleteScanNumberCache(numberCachePtr); + break; + } + } return TCL_OK; - badCount: + badValue: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected ", errorString, + " string but got \"", errorValue, "\" instead", NULL); + return TCL_ERROR; + + 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 = 0; - char buf[5] = ""; + Tcl_UniChar ch; + char buf[TCL_UTF_MAX + 1]; - TclUtfToUniChar(errorString, &ch); + Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad field specifier \"%s\"", buf)); + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } - error: - Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); + error: + Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } @@ -1828,9 +1493,9 @@ BinaryScanCmd( static int GetFormatSpec( - const char **formatPtr, /* Pointer to format string. */ + char **formatPtr, /* Pointer to format string. */ char *cmdPtr, /* Pointer to location of command char. */ - Tcl_Size *countPtr, /* Pointer to repeat count value. */ + int *countPtr, /* Pointer to repeat count value. */ int *flagsPtr) /* Pointer to field flags */ { /* @@ -1857,23 +1522,15 @@ GetFormatSpec( (*formatPtr)++; if (**formatPtr == 'u') { (*formatPtr)++; - *flagsPtr |= BINARY_UNSIGNED; + (*flagsPtr) |= BINARY_UNSIGNED; } if (**formatPtr == '*') { (*formatPtr)++; - *countPtr = BINARY_ALL; + (*countPtr) = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - unsigned long count; - - errno = 0; - count = strtoul(*formatPtr, (char **) formatPtr, 10); - if (errno || (count > (unsigned long) INT_MAX)) { - *countPtr = INT_MAX; - } else { - *countPtr = (int) count; - } + (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { - *countPtr = BINARY_NOCOUNT; + (*countPtr) = BINARY_NOCOUNT; } return 1; } @@ -1885,7 +1542,7 @@ GetFormatSpec( * * This routine determines, if bytes of a number need to be re-ordered, * and returns a numeric code indicating the re-ordering to be done. - * This depends on the endianness of the machine and the desired format. + * 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 @@ -1996,16 +1653,16 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - unsigned length, /* Number of bytes to copy */ + unsigned int length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { - case 0: + case 0: memcpy(to, from, length); break; case 1: { - const unsigned char *fromPtr = (const unsigned char *)from; - unsigned char *toPtr = (unsigned char *)to; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; switch (length) { case 4: @@ -2028,8 +1685,8 @@ CopyNumber( break; } case 2: { - const unsigned char *fromPtr = (const unsigned char *)from; - unsigned char *toPtr = (unsigned char *)to; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; toPtr[0] = fromPtr[4]; toPtr[1] = fromPtr[5]; @@ -2042,8 +1699,8 @@ CopyNumber( break; } case 3: { - const unsigned char *fromPtr = (const unsigned char *)from; - unsigned char *toPtr = (unsigned char *)to; + const unsigned char *fromPtr = from; + unsigned char *toPtr = to; toPtr[0] = fromPtr[3]; toPtr[1] = fromPtr[2]; @@ -2063,7 +1720,7 @@ CopyNumber( * * FormatNumber -- * - * This routine is called by BinaryFormatCmd to format a number into a + * This routine is called by Tcl_BinaryObjCmd to format a number into a * location pointed at by cursor. * * Results: @@ -2083,6 +1740,7 @@ FormatNumber( Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { + long value; double dvalue; Tcl_WideInt wvalue; float fvalue; @@ -2098,11 +1756,10 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); @@ -2118,12 +1775,10 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(src, &tclDoubleType); - - if (irPtr == NULL) { + if (src->typePtr != &tclDoubleType) { return TCL_ERROR; } - dvalue = irPtr->doubleValue; + dvalue = src->internalRep.doubleValue; } /* @@ -2132,12 +1787,8 @@ FormatNumber( * valid range for float. */ - if (fabs(dvalue) > (double) FLT_MAX) { - if (fabs(dvalue) > (FLT_MAX + pow(2, (FLT_MAX_EXP - FLT_MANT_DIG - 1)))) { - fvalue = (dvalue >= 0.0) ? INFINITY : -INFINITY; // c99 - } else { + if (fabs(dvalue) > (double)FLT_MAX) { fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; - } } else { fvalue = (float) dvalue; } @@ -2151,27 +1802,27 @@ FormatNumber( case 'w': case 'W': case 'm': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 32); - *(*cursorPtr)++ = UCHAR(wvalue >> 40); - *(*cursorPtr)++ = UCHAR(wvalue >> 48); - *(*cursorPtr)++ = UCHAR(wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) wvalue; + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 56); - *(*cursorPtr)++ = UCHAR(wvalue >> 48); - *(*cursorPtr)++ = UCHAR(wvalue >> 40); - *(*cursorPtr)++ = UCHAR(wvalue >> 32); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) wvalue; } return TCL_OK; @@ -2181,19 +1832,19 @@ FormatNumber( case 'i': case 'I': case 'n': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 24); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 24); - *(*cursorPtr)++ = UCHAR(wvalue >> 16); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (value >> 24); + *(*cursorPtr)++ = (unsigned char) (value >> 16); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } return TCL_OK; @@ -2203,15 +1854,15 @@ FormatNumber( case 's': case 'S': case 't': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(wvalue); - *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) value; + *(*cursorPtr)++ = (unsigned char) (value >> 8); } else { - *(*cursorPtr)++ = UCHAR(wvalue >> 8); - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) (value >> 8); + *(*cursorPtr)++ = (unsigned char) value; } return TCL_OK; @@ -2219,10 +1870,10 @@ FormatNumber( * 8-bit integer values. */ case 'c': - if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } - *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = (unsigned char) value; return TCL_OK; default: @@ -2236,7 +1887,7 @@ FormatNumber( * * ScanNumber -- * - * This routine is called by BinaryScanCmd to scan a number out of a + * This routine is called by Tcl_BinaryObjCmd to scan a number out of a * buffer. * * Results: @@ -2257,9 +1908,9 @@ ScanNumber( int type, /* Format character from "binary scan" */ int flags, /* Format field flags */ Tcl_HashTable **numberCachePtrPtr) - /* Place to look for cache of scanned value - * objects, or NULL if too many different - * numbers have been scanned. */ + /* Place to look for cache of scanned + * value objects, or NULL if too many + * different numbers have been scanned. */ { long value; float fvalue; @@ -2322,18 +1973,17 @@ ScanNumber( value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) - + (((unsigned long)buffer[3]) << 24)); + + (((long)buffer[3]) << 24)); } else { value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) - + (((unsigned long) buffer[0]) << 24)); + + (((long)buffer[0]) << 24)); } /* * Check to see if the value was sign extended properly on systems * where an int is more than 32-bits. - * * We avoid caching unsigned integers as we cannot distinguish between * 32bit signed and unsigned in the hash (short and char are ok). */ @@ -2341,29 +1991,28 @@ ScanNumber( if (flags & BINARY_UNSIGNED) { return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); } - if ((value & (1U << 31)) && (value > 0)) { - value -= (1U << 31); - value -= (1U << 31); + if ((value & (((unsigned int)1)<<31)) && (value > 0)) { + value -= (((unsigned int)1)<<31); + value -= (((unsigned int)1)<<31); } returnNumericObject: if (*numberCachePtrPtr == NULL) { - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } else { - Tcl_HashTable *tablePtr = *numberCachePtrPtr; - Tcl_HashEntry *hPtr; + register Tcl_HashTable *tablePtr = *numberCachePtrPtr; + register Tcl_HashEntry *hPtr; int isNew; hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew); if (!isNew) { - return (Tcl_Obj *)Tcl_GetHashValue(hPtr); + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - Tcl_Obj *objPtr; + register Tcl_Obj *objPtr = Tcl_NewLongObj(value); - TclNewIntObj(objPtr, value); Tcl_IncrRefCount(objPtr); - Tcl_SetHashValue(hPtr, objPtr); + Tcl_SetHashValue(hPtr, (ClientData) objPtr); return objPtr; } @@ -2378,7 +2027,7 @@ ScanNumber( DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; - return Tcl_NewWideIntObj(value); + return Tcl_NewLongObj(value); } /* @@ -2412,9 +2061,8 @@ ScanNumber( Tcl_Obj *bigObj = NULL; mp_int big; - if (mp_init_u64(&big, uwvalue) == MP_OKAY) { - bigObj = Tcl_NewBignumObj(&big); - } + TclBNInitBignumFromWideUInt(&big, uwvalue); + bigObj = Tcl_NewBignumObj(&big); return bigObj; } return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); @@ -2480,7 +2128,7 @@ DeleteScanNumberCache( hEntry = Tcl_FirstHashEntry(numberCachePtr, &search); while (hEntry != NULL) { - Tcl_Obj *value = (Tcl_Obj *)Tcl_GetHashValue(hEntry); + register Tcl_Obj *value = Tcl_GetHashValue(hEntry); if (value != NULL) { Tcl_DecrRefCount(value); @@ -2491,815 +2139,6 @@ DeleteScanNumberCache( } /* - * ---------------------------------------------------------------------- - * - * NOTES -- - * - * Some measurements show that it is faster to use a table to to perform - * uuencode and base64 value encoding than to calculate the output (at - * least on intel P4 arch). - * - * Conversely using a lookup table for the decoding is slower than just - * calculating the values. We therefore use the fastest of each method. - * - * Presumably this has to do with the size of the tables. The base64 - * decode table is 255 bytes while the encode table is only 65 bytes. The - * choice likely depends on CPU memory cache sizes. - */ - -/* - *---------------------------------------------------------------------- - * - * BinaryEncodeHex -- - * - * Implement the [binary encode hex] binary encoding. clientData must be - * a table to convert values to hexadecimal digits. - * - * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -BinaryEncodeHex( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj = NULL; - unsigned char *data = NULL; - unsigned char *cursor = NULL; - Tcl_Size offset = 0, count = 0; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "data"); - return TCL_ERROR; - } - - TclNewObj(resultObj); - data = Tcl_GetByteArrayFromObj(objv[1], &count); - cursor = Tcl_SetByteArrayLength(resultObj, count * 2); - for (offset = 0; offset < count; ++offset) { - *cursor++ = HexDigits[(data[offset] >> 4) & 0x0F]; - *cursor++ = HexDigits[data[offset] & 0x0F]; - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecodeHex -- - * - * Implement the [binary decode hex] binary encoding. - * - * Results: - * Interp result set to an decoded byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -BinaryDecodeHex( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj = NULL; - unsigned char *data, *datastart, *dataend; - unsigned char *begin, *cursor, c; - int i, index, value, pure = 1, strict = 0; - Tcl_Size size, cut = 0, count = 0; - int ucs4; - enum {OPT_STRICT }; - static const char *const optStrings[] = { "-strict", NULL }; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; ++i) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_STRICT: - strict = 1; - break; - } - } - - TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); - if (data == NULL) { - pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); - } - datastart = data; - dataend = data + count; - size = (count + 1) / 2; - begin = cursor = Tcl_SetByteArrayLength(resultObj, size); - while (data < dataend) { - value = 0; - for (i = 0 ; i < 2 ; i++) { - if (data >= dataend) { - value <<= 4; - break; - } - - c = *data++; - if (!isxdigit(UCHAR(c))) { - if (strict || !TclIsSpaceProc(c)) { - goto badChar; - } - i--; - continue; - } - - value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); - } - value |= c & 0xF; - } - if (i < 2) { - cut++; - } - *cursor++ = UCHAR(value); - value = 0; - } - if (cut > size) { - cut = size; - } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - - badChar: - if (pure) { - ucs4 = c; - } else { - TclUtfToUniChar((const char *)(data - 1), &ucs4); - } - TclDecrRefCount(resultObj); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryEncode64 -- - * - * This procedure implements the "binary encode base64" Tcl command. - * - * Results: - * The base64 encoded value prescribed by the input arguments. - * - *---------------------------------------------------------------------- - */ - -#define OUTPUT(c) \ - do { \ - *cursor++ = (c); \ - outindex++; \ - if (maxlen > 0 && cursor != limit) { \ - if (outindex == maxlen) { \ - memcpy(cursor, wrapchar, wrapcharlen); \ - cursor += wrapcharlen; \ - outindex = 0; \ - } \ - } \ - if (cursor > limit) { \ - Tcl_Panic("limit hit"); \ - } \ - } while (0) - -static int -BinaryEncode64( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj; - unsigned char *data, *limit; - Tcl_WideInt maxlen = 0; - const char *wrapchar = "\n"; - Tcl_Size wrapcharlen = 1; - int index, purewrap = 1; - Tcl_Size i, offset, size, outindex = 0, count = 0; - enum { OPT_MAXLEN, OPT_WRAPCHAR }; - static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; - - if (objc < 2 || objc % 2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, - "?-maxlen len? ?-wrapchar char? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_MAXLEN: - if (Tcl_GetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { - return TCL_ERROR; - } - if (maxlen < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "line length out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", (void *)NULL); - return TCL_ERROR; - } - break; - case OPT_WRAPCHAR: - wrapchar = (const char *)Tcl_GetBytesFromObj(NULL, - objv[i + 1], &wrapcharlen); - if (wrapchar == NULL) { - purewrap = 0; - wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); - } - break; - } - } - if (wrapcharlen == 0) { - maxlen = 0; - } - - TclNewObj(resultObj); - data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); - if (count > 0) { - unsigned char *cursor = NULL; - - size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */ - if (maxlen > 0 && size > maxlen) { - int adjusted = size + (wrapcharlen * (size / maxlen)); - - if (size % maxlen == 0) { - adjusted -= wrapcharlen; - } - size = adjusted; - - if (purewrap == 0) { - /* Wrapchar is (possibly) non-byte, so build result as - * general string, not bytearray */ - Tcl_SetObjLength(resultObj, size); - cursor = (unsigned char *) TclGetString(resultObj); - } - } - if (cursor == NULL) { - cursor = Tcl_SetByteArrayLength(resultObj, size); - } - limit = cursor + size; - for (offset = 0; offset < count; offset += 3) { - unsigned char d[3] = {0, 0, 0}; - - for (i = 0; i < 3 && offset + i < count; ++i) { - d[i] = data[offset + i]; - } - OUTPUT(B64Digits[d[0] >> 2]); - OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); - if (offset + 1 < count) { - OUTPUT(B64Digits[((d[1] & 0x0F) << 2) | (d[2] >> 6)]); - } else { - OUTPUT(B64Digits[64]); - } - if (offset+2 < count) { - OUTPUT(B64Digits[d[2] & 0x3F]); - } else { - OUTPUT(B64Digits[64]); - } - } - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} -#undef OUTPUT - -/* - *---------------------------------------------------------------------- - * - * BinaryEncodeUu -- - * - * This implements the uuencode binary encoding. Input is broken into 6 - * bit chunks and a lookup table is used to turn these values into output - * characters. This differs from the generic code above in that line - * lengths are also encoded. - * - * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -BinaryEncodeUu( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj; - unsigned char *data, *start, *cursor; - int i, bits, index; - unsigned int n; - int lineLength = 61; - const unsigned char SingleNewline[] = { UCHAR('\n') }; - const unsigned char *wrapchar = SingleNewline; - Tcl_Size j, rawLength, offset, count, wrapcharlen = sizeof(SingleNewline); - enum { OPT_MAXLEN, OPT_WRAPCHAR }; - static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; - - if (objc < 2 || objc % 2 != 0) { - Tcl_WrongNumArgs(interp, 1, objv, - "?-maxlen len? ?-wrapchar char? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; i += 2) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_MAXLEN: - if (Tcl_GetIntFromObj(interp, objv[i + 1], - &lineLength) != TCL_OK) { - return TCL_ERROR; - } - if (lineLength < 5 || lineLength > 85) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "line length out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", (void *)NULL); - return TCL_ERROR; - } - lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ - break; - case OPT_WRAPCHAR: - wrapchar = (const unsigned char *) TclGetStringFromObj( - objv[i + 1], &wrapcharlen); - { - const unsigned char *p = wrapchar; - Tcl_Size numBytes = wrapcharlen; - - while (numBytes) { - switch (*p) { - case '\t': - case '\v': - case '\f': - case '\r': - p++; numBytes--; - continue; - case '\n': - numBytes--; - break; - default: - badwrap: - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invalid wrapchar; will defeat decoding", - -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", (void *)NULL); - return TCL_ERROR; - } - } - if (numBytes) { - goto badwrap; - } - } - break; - } - } - - /* - * Allocate the buffer. This is a little bit too long, but is "good - * enough". - */ - - TclNewObj(resultObj); - offset = 0; - data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); - rawLength = (lineLength - 1) * 3 / 4; - start = cursor = Tcl_SetByteArrayLength(resultObj, - (lineLength + wrapcharlen) * - ((count + (rawLength - 1)) / rawLength)); - n = bits = 0; - - /* - * Encode the data. Each output line first has the length of raw data - * encoded by the output line described in it by one encoded byte, then - * the encoded data follows (encoding each 6 bits as one character). - * Encoded lines are always terminated by a newline. - */ - - while (offset < count) { - Tcl_Size lineLen = count - offset; - - if (lineLen > rawLength) { - lineLen = rawLength; - } - *cursor++ = UueDigits[lineLen]; - for (i = 0 ; i < lineLen ; i++) { - n <<= 8; - n |= data[offset++]; - for (bits += 8; bits > 6 ; bits -= 6) { - *cursor++ = UueDigits[(n >> (bits - 6)) & 0x3F]; - } - } - if (bits > 0) { - n <<= 8; - *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3F]; - bits = 0; - } - for (j = 0 ; j < wrapcharlen ; ++j) { - *cursor++ = wrapchar[j]; - } - } - - /* - * Fix the length of the output bytearray. - */ - - Tcl_SetByteArrayLength(resultObj, cursor - start); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecodeUu -- - * - * Decode a uuencoded string. - * - * Results: - * Interp result set to an byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -BinaryDecodeUu( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj = NULL; - unsigned char *data, *datastart, *dataend; - unsigned char *begin, *cursor; - int i, index, pure = 1, strict = 0, lineLen; - Tcl_Size size, count = 0; - unsigned char c; - int ucs4; - enum { OPT_STRICT }; - static const char *const optStrings[] = { "-strict", NULL }; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; ++i) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_STRICT: - strict = 1; - break; - } - } - - TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); - if (data == NULL) { - pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); - } - datastart = data; - dataend = data + count; - size = ((count + 3) & ~3) * 3 / 4; - begin = cursor = Tcl_SetByteArrayLength(resultObj, size); - lineLen = -1; - - /* - * The decoding loop. First, we get the length of line (strictly, the - * number of data bytes we expect to generate from the line) we're - * processing this time round if it is not already known (i.e., when the - * lineLen variable is set to the magic value, -1). - */ - - while (data < dataend) { - char d[4] = {0, 0, 0, 0}; - - if (lineLen < 0) { - c = *data++; - if (c < 32 || c > 96) { - if (strict || !TclIsSpaceProc(c)) { - goto badUu; - } - i--; - continue; - } - lineLen = (c - 32) & 0x3F; - } - - /* - * Now we read a four-character grouping. - */ - - for (i = 0 ; i < 4 ; i++) { - if (data < dataend) { - d[i] = c = *data++; - if (c < 32 || c > 96) { - if (strict) { - if (!TclIsSpaceProc(c)) { - goto badUu; - } else if (c == '\n') { - goto shortUu; - } - } - i--; - continue; - } - } - } - - /* - * Translate that grouping into (up to) three binary bytes output. - */ - - if (lineLen > 0) { - *cursor++ = (((d[0] - 0x20) & 0x3F) << 2) - | (((d[1] - 0x20) & 0x3F) >> 4); - if (--lineLen > 0) { - *cursor++ = (((d[1] - 0x20) & 0x3F) << 4) - | (((d[2] - 0x20) & 0x3F) >> 2); - if (--lineLen > 0) { - *cursor++ = (((d[2] - 0x20) & 0x3F) << 6) - | (((d[3] - 0x20) & 0x3F)); - lineLen--; - } - } - } - - /* - * If we've reached the end of the line, skip until we process a - * newline. - */ - - if (lineLen == 0 && data < dataend) { - lineLen = -1; - do { - c = *data++; - if (c == '\n') { - break; - } else if (c >= 32 && c <= 96) { - data--; - break; - } else if (strict || !TclIsSpaceProc(c)) { - goto badUu; - } - } while (data < dataend); - } - } - - /* - * Sanity check, clean up and finish. - */ - - if (lineLen > 0 && strict) { - goto shortUu; - } - Tcl_SetByteArrayLength(resultObj, cursor - begin); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - - shortUu: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (void *)NULL); - TclDecrRefCount(resultObj); - return TCL_ERROR; - - badUu: - if (pure) { - ucs4 = c; - } else { - TclUtfToUniChar((const char *)(data - 1), &ucs4); - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); - TclDecrRefCount(resultObj); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryDecode64 -- - * - * Decode a base64 encoded string. - * - * Results: - * Interp result set to an byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -BinaryDecode64( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj = NULL; - unsigned char *data, *datastart, *dataend, c = '\0'; - unsigned char *begin = NULL; - unsigned char *cursor = NULL; - int pure = 1, strict = 0; - int i, index, cut = 0; - Tcl_Size size, count = 0; - int ucs4; - enum { OPT_STRICT }; - static const char *const optStrings[] = { "-strict", NULL }; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); - return TCL_ERROR; - } - for (i = 1; i < objc - 1; ++i) { - if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", - TCL_EXACT, &index) != TCL_OK) { - return TCL_ERROR; - } - switch (index) { - case OPT_STRICT: - strict = 1; - break; - } - } - - TclNewObj(resultObj); - data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); - if (data == NULL) { - pure = 0; - data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); - } - datastart = data; - dataend = data + count; - size = ((count + 3) & ~3) * 3 / 4; - begin = cursor = Tcl_SetByteArrayLength(resultObj, size); - while (data < dataend) { - unsigned long value = 0; - - /* - * Decode the current block. Each base64 block consists of four input - * characters A-Z, a-z, 0-9, +, or /. Each character supplies six bits - * of output data, so each block's output is 24 bits (three bytes) in - * length. The final block can be shorter by one or two bytes, denoted - * by the input ending with one or two ='s, respectively. - */ - - for (i = 0; i < 4; i++) { - /* - * Get the next input character. At end of input, pad with at most - * two ='s. If more than two ='s would be needed, instead discard - * the block read thus far. - */ - - if (data < dataend) { - c = *data++; - } else if (i > 1) { - c = '='; - } else { - if (strict && i <= 1) { - /* - * Single resp. unfulfilled char (each 4th next single - * char) is rather bad64 error case in strict mode. - */ - - goto bad64; - } - cut += 3; - break; - } - - /* - * Load the character into the block value. Handle ='s specially - * because they're only valid as the last character or two of the - * final block of input. Unless strict mode is enabled, skip any - * input whitespace characters. - */ - - if (cut) { - if (c == '=' && i > 1) { - value <<= 6; - cut++; - } else if (!strict) { - i--; - } else { - goto bad64; - } - } else if (c >= 'A' && c <= 'Z') { - value = (value << 6) | ((c - 'A') & 0x3F); - } else if (c >= 'a' && c <= 'z') { - value = (value << 6) | ((c - 'a' + 26) & 0x3F); - } else if (c >= '0' && c <= '9') { - value = (value << 6) | ((c - '0' + 52) & 0x3F); - } else if (c == '+') { - value = (value << 6) | 0x3E; - } else if (c == '/') { - value = (value << 6) | 0x3F; - } else if (c == '=' && (!strict || i > 1)) { - /* - * "=" and "a=" is rather bad64 error case in strict mode. - */ - - value <<= 6; - if (i) { - cut++; - } - } else if (strict) { - goto bad64; - } else { - i--; - } - } - *cursor++ = UCHAR((value >> 16) & 0xFF); - *cursor++ = UCHAR((value >> 8) & 0xFF); - *cursor++ = UCHAR(value & 0xFF); - - /* - * Since = is only valid within the final block, if it was encountered - * but there are still more input characters, confirm that strict mode - * is off and all subsequent characters are whitespace. - */ - - if (cut && data < dataend) { - if (strict) { - goto bad64; - } - } - } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - - bad64: - if (pure) { - ucs4 = c; - } else { - /* The decoder is byte-oriented. If we saw a byte that's not a - * valid member of the base64 alphabet, it could be the lead byte - * of a multi-byte character. */ - - /* Safe because we know data is NUL-terminated */ - TclUtfToUniChar((const char *)(data - 1), &ucs4); - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" (U+%06X) at position %d", - ucs4, ucs4, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); - TclDecrRefCount(resultObj); - return TCL_ERROR; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 |