diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:13:18 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-12-21 22:13:18 (GMT) |
commit | 07e464099b99459d0a37757771791598ef3395d9 (patch) | |
tree | 4ba7d8aad13735e52f59bdce7ca5ba3151ebd7e3 /tcl8.6/generic/tclBinary.c | |
parent | deb3650e37f26f651f280e480c4df3d7dde87bae (diff) | |
download | blt-07e464099b99459d0a37757771791598ef3395d9.zip blt-07e464099b99459d0a37757771791598ef3395d9.tar.gz blt-07e464099b99459d0a37757771791598ef3395d9.tar.bz2 |
new subtree for tcl/tk
Diffstat (limited to 'tcl8.6/generic/tclBinary.c')
-rw-r--r-- | tcl8.6/generic/tclBinary.c | 2988 |
1 files changed, 0 insertions, 2988 deletions
diff --git a/tcl8.6/generic/tclBinary.c b/tcl8.6/generic/tclBinary.c deleted file mode 100644 index 981f174..0000000 --- a/tcl8.6/generic/tclBinary.c +++ /dev/null @@ -1,2988 +0,0 @@ -/* - * tclBinary.c -- - * - * This file contains the implementation of the "binary" Tcl built-in - * command and the Tcl binary data object. - * - * 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 "tommath.h" - -#include <math.h> - -/* - * The following constants are used by GetFormatSpec to indicate various - * special conditions in the parsing of a format specifier. - */ - -#define BINARY_ALL -1 /* Use all elements in the argument. */ -#define BINARY_NOCOUNT -2 /* No count was specified in format. */ - -/* - * The following flags may be ORed together and returned by GetFormatSpec - */ - -#define BINARY_SIGNED 0 /* Field to be read as signed data */ -#define BINARY_UNSIGNED 1 /* Field to be read as unsigned data */ - -/* - * The following defines the maximum number of different (integer) numbers - * placed in the object cache by 'binary scan' before it bails out and - * switches back to Plan A (creating a new object for each value.) - * Theoretically, it would be possible to keep the cache about for the values - * that are already in it, but that makes the code slower in practise when - * overflow happens, and makes little odds the rest of the time (as measured - * on my machine.) It is also slower (on the sample I tried at least) to grow - * the cache to hold all items we might want to put in it; presumably the - * extra cost of managing the memory for the enlarged table outweighs the - * benefit from allocating fewer objects. This is probably because as the - * number of objects increases, the likelihood of reuse of any particular one - * drops, and there is very little gain from larger maximum cache sizes (the - * value below is chosen to allow caching to work in full with conversion of - * bytes.) - DKF - */ - -#define BINARY_SCAN_MAX_CACHE 260 - -/* - * Prototypes for local procedures defined in this file: - */ - -static void DupByteArrayInternalRep(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 int GetFormatSpec(const 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, - Tcl_Obj *objPtr); -static void UpdateStringOfByteArray(Tcl_Obj *listPtr); -static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); -static int NeedReversing(int format); -static void CopyNumber(const void *from, void *to, - unsigned length, int type); -/* Binary ensemble commands */ -static int BinaryFormatCmd(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryScanCmd(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -/* Binary encoding sub-ensemble commands */ -static int BinaryEncodeHex(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeHex(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryEncode64(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); -static int BinaryEncodeUu(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, - Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); - -/* - * 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 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. - */ - -const Tcl_ObjType tclByteArrayType = { - "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, - UpdateStringOfByteArray, - SetByteArrayFromAny -}; - -/* - * The following structure is the internal rep for a ByteArray object. Keeps - * track of how much memory has been used and how much has been allocated for - * the byte array to enable growing and shrinking of the ByteArray object with - * fewer mallocs. - */ - -typedef struct ByteArray { - 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[1]; /* The array of bytes. The actual size of this - * field depends on the 'allocated' field - * above. */ -} ByteArray; - -#define BYTEARRAY_SIZE(len) \ - ((unsigned) (TclOffset(ByteArray, bytes) + (len))) -#define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) - - -/* - *---------------------------------------------------------------------- - * - * Tcl_NewByteArrayObj -- - * - * This procedure is creates a new ByteArray object and initializes it - * from the given array of bytes. - * - * Results: - * The newly create object is returned. This object will have no initial - * string representation. The returned object has a ref count of 0. - * - * Side effects: - * Memory allocated for new object and copy of byte array argument. - * - *---------------------------------------------------------------------- - */ - -#undef Tcl_NewByteArrayObj - -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. */ -{ -#ifdef TCL_MEM_DEBUG - return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); -#else /* if not TCL_MEM_DEBUG */ - Tcl_Obj *objPtr; - - TclNewObj(objPtr); - Tcl_SetByteArrayObj(objPtr, bytes, length); - return objPtr; -#endif /* TCL_MEM_DEBUG */ -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_DbNewByteArrayObj -- - * - * This procedure is normally called when debugging: i.e., when - * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj - * above except that it calls Tcl_DbCkalloc directly with the file name - * and line number from its caller. This simplifies debugging since then - * the [memory active] command will report the correct file name and line - * number when reporting objects that haven't been freed. - * - * When TCL_MEM_DEBUG is not defined, this procedure just returns the - * result of calling Tcl_NewByteArrayObj. - * - * Results: - * The newly create object is returned. This object will have no initial - * string representation. The returned object has a ref count of 0. - * - * Side effects: - * Memory allocated for new object and copy of byte array argument. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -Tcl_DbNewByteArrayObj( - const unsigned char *bytes, /* The array of bytes used to initialize the - * new object. */ - int length, /* Length of the array of bytes, which must be - * >= 0. */ - const char *file, /* The name of the source file calling this - * procedure; used for debugging. */ - int line) /* Line number in the source file; used for - * debugging. */ -{ -#ifdef TCL_MEM_DEBUG - Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - Tcl_SetByteArrayObj(objPtr, bytes, length); - return objPtr; -#else /* if not TCL_MEM_DEBUG */ - return Tcl_NewByteArrayObj(bytes, length); -#endif /* TCL_MEM_DEBUG */ -} - -/* - *--------------------------------------------------------------------------- - * - * Tcl_SetByteArrayObj -- - * - * Modify an object to be a ByteArray object and to have the specified - * array of bytes as its value. - * - * Results: - * None. - * - * Side effects: - * The object's old string rep and internal rep is freed. Memory - * allocated for copy of byte array argument. - * - *---------------------------------------------------------------------- - */ - -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 length > 0. */ - int length) /* Length of the array of bytes, which must - be >= 0. */ -{ - ByteArray *byteArrayPtr; - - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); - } - TclFreeIntRep(objPtr); - TclInvalidateStringRep(objPtr); - - if (length < 0) { - length = 0; - } - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - byteArrayPtr->used = length; - byteArrayPtr->allocated = length; - - if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); - } - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetByteArrayFromObj -- - * - * Attempt to get the array of bytes from the Tcl object. If the object - * is not already a ByteArray object, an attempt will be made to convert - * it to one. - * - * Results: - * Pointer to array of bytes representing the ByteArray object. - * - * Side effects: - * Frees old internal rep. Allocates memory for new internal rep. - * - *---------------------------------------------------------------------- - */ - -unsigned char * -Tcl_GetByteArrayFromObj( - Tcl_Obj *objPtr, /* The ByteArray object. */ - int *lengthPtr) /* If non-NULL, filled with length of the - * array of bytes in the ByteArray object. */ -{ - ByteArray *baPtr; - - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); - } - baPtr = GET_BYTEARRAY(objPtr); - - if (lengthPtr != NULL) { - *lengthPtr = baPtr->used; - } - return (unsigned char *) baPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_SetByteArrayLength -- - * - * This procedure changes the length of the byte array for this object. - * Once the caller has set the length of the array, it is acceptable to - * directly modify the bytes in the array up until Tcl_GetStringFromObj() - * has been called on this object. - * - * Results: - * The new byte array of the specified length. - * - * Side effects: - * Allocates enough memory for an array of bytes of the requested size. - * When growing the array, the old array is copied to the new array; new - * bytes are undefined. When shrinking, the old array is truncated to the - * specified length. - * - *---------------------------------------------------------------------- - */ - -unsigned char * -Tcl_SetByteArrayLength( - Tcl_Obj *objPtr, /* The ByteArray object. */ - int length) /* New length for internal byte array. */ -{ - ByteArray *byteArrayPtr; - - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); - } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); - } - - byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; - SET_BYTEARRAY(objPtr, byteArrayPtr); - } - TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; - return byteArrayPtr->bytes; -} - -/* - *---------------------------------------------------------------------- - * - * SetByteArrayFromAny -- - * - * Generate the ByteArray internal rep from the string rep. - * - * Results: - * The return value is always TCL_OK. - * - * Side effects: - * A ByteArray object is stored as the internal rep of objPtr. - * - *---------------------------------------------------------------------- - */ - -static int -SetByteArrayFromAny( - Tcl_Interp *interp, /* Not used. */ - Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ -{ - int length; - const char *src, *srcEnd; - unsigned char *dst; - ByteArray *byteArrayPtr; - Tcl_UniChar ch; - - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; - - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += Tcl_UtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } - - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; - - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * FreeByteArrayInternalRep -- - * - * Deallocate the storage associated with a ByteArray data object's - * internal representation. - * - * Results: - * None. - * - * Side effects: - * Frees memory. - * - *---------------------------------------------------------------------- - */ - -static void -FreeByteArrayInternalRep( - Tcl_Obj *objPtr) /* Object with internal rep to free. */ -{ - ckfree(GET_BYTEARRAY(objPtr)); - objPtr->typePtr = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DupByteArrayInternalRep -- - * - * Initialize the internal representation of a ByteArray Tcl_Obj to a - * copy of the internal representation of an existing ByteArray object. - * - * Results: - * None. - * - * Side effects: - * Allocates memory. - * - *---------------------------------------------------------------------- - */ - -static void -DupByteArrayInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ -{ - int length; - ByteArray *srcArrayPtr, *copyArrayPtr; - - srcArrayPtr = GET_BYTEARRAY(srcPtr); - length = srcArrayPtr->used; - - copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - copyArrayPtr->used = length; - copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); - SET_BYTEARRAY(copyPtr, copyArrayPtr); - - copyPtr->typePtr = &tclByteArrayType; -} - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfByteArray -- - * - * Update the string representation for a ByteArray data object. Note: - * This procedure does not invalidate an existing old string rep so - * storage will be lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * 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. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfByteArray( - Tcl_Obj *objPtr) /* ByteArray object whose string rep to - * update. */ -{ - 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? - */ - - size = length; - for (i = 0; i < length && size >= 0; i++) { - if ((src[i] == 0) || (src[i] > 127)) { - size++; - } - } - if (size < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - dst = ckalloc(size + 1); - objPtr->bytes = dst; - objPtr->length = size; - - if (size == length) { - memcpy(dst, src, (size_t) size); - dst[size] = '\0'; - } else { - for (i = 0; i < length; i++) { - dst += Tcl_UniCharToUtf(src[i], dst); - } - *dst = '\0'; - } -} - -/* - *---------------------------------------------------------------------- - * - * TclAppendBytesToByteArray -- - * - * This function appends an array of bytes to a byte array object. Note - * that the object *must* be unshared, and the array of bytes *must not* - * refer to the object being appended to. - * - * Results: - * None. - * - * Side effects: - * Allocates enough memory for an array of bytes of the requested total - * size, or possibly larger. [Bug 2992970] - * - *---------------------------------------------------------------------- - */ - -void -TclAppendBytesToByteArray( - Tcl_Obj *objPtr, - const unsigned char *bytes, - int len) -{ - ByteArray *byteArrayPtr; - int needed; - - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); - } - if (len < 0) { - Tcl_Panic("%s must be called with definite number of bytes to append", - "TclAppendBytesToByteArray"); - } - if (len == 0) { - /* Append zero bytes is a no-op. */ - return; - } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); - } - byteArrayPtr = GET_BYTEARRAY(objPtr); - - if (len > INT_MAX - byteArrayPtr->used) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - needed = byteArrayPtr->used + len; - /* - * If we need to, resize the allocated space in the byte array. - */ - - if (needed > byteArrayPtr->allocated) { - ByteArray *ptr = NULL; - int attempt; - - if (needed <= INT_MAX/2) { - /* Try to allocate double the total space that is needed. */ - attempt = 2 * needed; - ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - if (ptr == NULL) { - /* Try to allocate double the increment that is needed (plus). */ - unsigned int limit = INT_MAX - needed; - unsigned int extra = len + TCL_MIN_GROWTH; - int growth = (int) ((extra > limit) ? limit : extra); - - attempt = needed + growth; - ptr = attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - if (ptr == NULL) { - /* Last chance: Try to allocate exactly what is needed. */ - attempt = needed; - ptr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); - } - byteArrayPtr = ptr; - byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(objPtr, byteArrayPtr); - } - - if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); - } - byteArrayPtr->used += len; - TclInvalidateStringRep(objPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclInitBinaryCmd -- - * - * 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. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -static int -BinaryFormatCmd( - ClientData dummy, /* Not used. */ - 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. */ - int 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. */ - unsigned char *cursor; /* Current position within result buffer. */ - unsigned char *maxPos; /* Greatest position within result buffer that - * cursor has visited.*/ - const char *errorString; - const char *errorValue, *str; - int offset, size, length; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg ...?"); - return TCL_ERROR; - } - - /* - * To avoid copying the data, we format the string in two passes. The - * first pass computes the size of the output buffer. The second pass - * places the formatted data into the buffer. - */ - - format = TclGetString(objv[1]); - arg = 2; - 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 (arg >= objc) { - goto badIndex; - } - if (count == BINARY_ALL) { - Tcl_GetByteArrayFromObj(objv[arg], &count); - } else if (count == BINARY_NOCOUNT) { - count = 1; - } - arg++; - if (cmd == 'a' || cmd == 'A') { - offset += count; - } else if (cmd == 'b' || cmd == 'B') { - offset += (count + 7) / 8; - } else { - offset += (count + 1) / 2; - } - break; - case 'c': - size = 1; - goto doNumbers; - case 't': - case 's': - case 'S': - size = 2; - goto doNumbers; - case 'n': - case 'i': - case 'I': - size = 4; - goto doNumbers; - case 'm': - case 'w': - case 'W': - size = 8; - goto doNumbers; - case 'r': - case 'R': - case 'f': - size = sizeof(float); - goto doNumbers; - case 'q': - case 'Q': - case 'd': - size = sizeof(double); - - doNumbers: - if (arg >= objc) { - goto badIndex; - } - - /* - * For number-type specifiers, the count corresponds to the number - * of elements in the list stored in a single argument. If no - * count is specified, then the argument is taken as a single - * non-list value. - */ - - 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_SetObjResult(interp, Tcl_NewStringObj( - "number of elements in list does not match count", - -1)); - return TCL_ERROR; - } - } - 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; - } - break; - default: - errorString = str; - goto badField; - } - } - if (offset > length) { - length = offset; - } - if (length == 0) { - return TCL_OK; - } - - /* - * Prepare the result object by preallocating the caclulated number of - * bytes and filling with nulls. - */ - - resultPtr = Tcl_NewObj(); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); - - /* - * Pack the data into the result object. Note that we can skip the - * error checking during this pass, since we have already parsed the - * string once. - */ - - arg = 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, (size_t) count); - } else { - memcpy(cursor, bytes, (size_t) length); - memset(cursor + length, pad, (size_t) (count - length)); - } - 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; - } - 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++ = 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++ = UCHAR(value); - value = 0; - } - } - } - if ((offset % 8) != 0) { - if (cmd == 'B') { - value <<= 8 - (offset % 8); - } else { - value >>= 8 - (offset % 8); - } - *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; - } - 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; - } - } - } 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++ = UCHAR(value & 0xff); - value = 0; - } - } - } - if (offset % 2) { - if (cmd == 'H') { - value <<= 4; - } else { - value >>= 4; - } - *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': { - 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; - } - } - arg++; - for (i = 0; i < count; i++) { - if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) { - Tcl_DecrRefCount(resultPtr); - return TCL_ERROR; - } - } - break; - } - case 'x': - if (count == BINARY_NOCOUNT) { - count = 1; - } - memset(cursor, 0, (size_t) count); - cursor += count; - break; - case 'X': - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > (cursor - buffer))) { - cursor = buffer; - } else { - cursor -= count; - } - break; - case '@': - if (cursor > maxPos) { - maxPos = cursor; - } - if (count == BINARY_ALL) { - cursor = maxPos; - } else { - cursor = buffer + count; - } - break; - } - } - Tcl_SetObjResult(interp, resultPtr); - 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; - char buf[TCL_UTF_MAX + 1]; - - Tcl_UtfToUniChar(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. - * - *---------------------------------------------------------------------- - */ - -int -BinaryScanCmd( - ClientData dummy, /* Not used. */ - 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. */ - int 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; - int offset, size, length; - - int 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; - } - switch (cmd) { - case 'a': - case 'A': { - unsigned char *src; - - if (arg >= objc) { - DeleteScanNumberCache(numberCachePtr); - goto badIndex; - } - if (count == BINARY_ALL) { - count = length - offset; - } else { - if (count == BINARY_NOCOUNT) { - count = 1; - } - if (count > (length - offset)) { - goto done; - } - } - - src = buffer + offset; - size = count; - - /* - * Trim trailing nulls and spaces, if necessary. - */ - - if (cmd == 'A') { - while (size > 0) { - if (src[size-1] != '\0' && src[size-1] != ' ') { - break; - } - 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. - */ - -#ifdef TCL_MEM_DEBUG - valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__, __LINE__); -#else - valuePtr = Tcl_NewByteArrayObj(src, size); -#endif /* TCL_MEM_DEBUG */ - - resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, - TCL_LEAVE_ERR_MSG); - arg++; - if (resultPtr == NULL) { - DeleteScanNumberCache(numberCachePtr); - 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; - } - } - 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'); - } - } - - 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; - } - } - 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]; - } - } - - 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; - } - 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; - } - case 'x': - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > (length - offset))) { - offset = length; - } else { - offset += count; - } - break; - case 'X': - if (count == BINARY_NOCOUNT) { - count = 1; - } - if ((count == BINARY_ALL) || (count > offset)) { - offset = 0; - } else { - offset -= count; - } - break; - case '@': - if (count == BINARY_NOCOUNT) { - DeleteScanNumberCache(numberCachePtr); - goto badCount; - } - if ((count == BINARY_ALL) || (count > length)) { - offset = length; - } else { - offset = count; - } - break; - default: - DeleteScanNumberCache(numberCachePtr); - errorString = str; - goto badField; - } - } - - /* - * Set the result to the last position of the cursor. - */ - - done: - Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3)); - DeleteScanNumberCache(numberCachePtr); - - return TCL_OK; - - badCount: - errorString = "missing count for \"@\" field specifier"; - goto error; - - badIndex: - errorString = "not enough arguments for all format specifiers"; - goto error; - - badField: - { - Tcl_UniChar ch; - char buf[TCL_UTF_MAX + 1]; - - Tcl_UtfToUniChar(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; -} - -/* - *---------------------------------------------------------------------- - * - * GetFormatSpec -- - * - * This function parses the format strings used in the binary format and - * scan commands. - * - * Results: - * Moves the formatPtr to the start of the next command. Returns the - * current command character and count in cmdPtr and countPtr. The count - * is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT - * if no count was specified. Returns 1 on success, or 0 if the string - * did not have a format specifier. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -GetFormatSpec( - const char **formatPtr, /* Pointer to format string. */ - char *cmdPtr, /* Pointer to location of command char. */ - int *countPtr, /* Pointer to repeat count value. */ - int *flagsPtr) /* Pointer to field flags */ -{ - /* - * Skip any leading blanks. - */ - - while (**formatPtr == ' ') { - (*formatPtr)++; - } - - /* - * The string was empty, except for whitespace, so fail. - */ - - if (!(**formatPtr)) { - return 0; - } - - /* - * Extract the command character and any trailing digits or '*'. - */ - - *cmdPtr = **formatPtr; - (*formatPtr)++; - if (**formatPtr == 'u') { - (*formatPtr)++; - *flagsPtr |= BINARY_UNSIGNED; - } - if (**formatPtr == '*') { - (*formatPtr)++; - *countPtr = BINARY_ALL; - } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - *countPtr = strtoul(*formatPtr, (char **) formatPtr, 10); - } else { - *countPtr = BINARY_NOCOUNT; - } - return 1; -} - -/* - *---------------------------------------------------------------------- - * - * NeedReversing -- - * - * 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 endiannes of the machine and the desired format. - * It is in effect a table (whose contents depend on the endianness of - * the system) describing whether a value needs reversing or not. Anyone - * porting the code to a big-endian platform should take care to make - * sure that they define WORDS_BIGENDIAN though this is already done by - * configure for the Unix build; little-endian platforms (including - * Windows) don't need to do anything. - * - * Results: - * 0 No re-ordering needed. - * 1 Reverse the bytes: 01234567 <-> 76543210 (little to big) - * 2 Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little) - * 3 Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big) - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -NeedReversing( - int format) -{ - switch (format) { - /* native floats and doubles: never reverse */ - case 'd': - case 'f': - /* big endian ints: never reverse */ - case 'I': - case 'S': - case 'W': -#ifdef WORDS_BIGENDIAN - /* native ints: reverse if we're little-endian */ - case 'n': - case 't': - case 'm': - /* f: reverse if we're little-endian */ - case 'Q': - case 'R': -#else /* !WORDS_BIGENDIAN */ - /* small endian floats: reverse if we're big-endian */ - case 'r': -#endif /* WORDS_BIGENDIAN */ - return 0; - -#ifdef WORDS_BIGENDIAN - /* small endian floats: reverse if we're big-endian */ - case 'q': - case 'r': -#else /* !WORDS_BIGENDIAN */ - /* native ints: reverse if we're little-endian */ - case 'n': - case 't': - case 'm': - /* f: reverse if we're little-endian */ - case 'R': -#endif /* WORDS_BIGENDIAN */ - /* small endian ints: always reverse */ - case 'i': - case 's': - case 'w': - return 1; - -#ifndef WORDS_BIGENDIAN - /* - * The Q and q formats need special handling to account for the unusual - * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be - * little-endian, but also reverse word order. - */ - - case 'Q': - if (TclNokia770Doubles()) { - return 3; - } - return 1; - case 'q': - if (TclNokia770Doubles()) { - return 2; - } - return 0; -#endif - } - - Tcl_Panic("unexpected fallthrough"); - return 0; -} - -/* - *---------------------------------------------------------------------- - * - * CopyNumber -- - * - * This routine is called by FormatNumber and ScanNumber to copy a - * floating-point number. If required, bytes are reversed while copying. - * The behaviour is only fully defined when used with IEEE float and - * double values (guaranteed to be 4 and 8 bytes long, respectively.) - * - * Results: - * None - * - * Side effects: - * Copies length bytes - * - *---------------------------------------------------------------------- - */ - -static void -CopyNumber( - const void *from, /* source */ - void *to, /* destination */ - unsigned length, /* Number of bytes to copy */ - int type) /* What type of thing are we copying? */ -{ - switch (NeedReversing(type)) { - case 0: - memcpy(to, from, length); - break; - case 1: { - const unsigned char *fromPtr = from; - unsigned char *toPtr = to; - - switch (length) { - case 4: - toPtr[0] = fromPtr[3]; - toPtr[1] = fromPtr[2]; - toPtr[2] = fromPtr[1]; - toPtr[3] = fromPtr[0]; - break; - case 8: - toPtr[0] = fromPtr[7]; - toPtr[1] = fromPtr[6]; - toPtr[2] = fromPtr[5]; - toPtr[3] = fromPtr[4]; - toPtr[4] = fromPtr[3]; - toPtr[5] = fromPtr[2]; - toPtr[6] = fromPtr[1]; - toPtr[7] = fromPtr[0]; - break; - } - break; - } - case 2: { - const unsigned char *fromPtr = from; - unsigned char *toPtr = to; - - toPtr[0] = fromPtr[4]; - toPtr[1] = fromPtr[5]; - toPtr[2] = fromPtr[6]; - toPtr[3] = fromPtr[7]; - toPtr[4] = fromPtr[0]; - toPtr[5] = fromPtr[1]; - toPtr[6] = fromPtr[2]; - toPtr[7] = fromPtr[3]; - break; - } - case 3: { - const unsigned char *fromPtr = from; - unsigned char *toPtr = to; - - toPtr[0] = fromPtr[3]; - toPtr[1] = fromPtr[2]; - toPtr[2] = fromPtr[1]; - toPtr[3] = fromPtr[0]; - toPtr[4] = fromPtr[7]; - toPtr[5] = fromPtr[6]; - toPtr[6] = fromPtr[5]; - toPtr[7] = fromPtr[4]; - break; - } - } -} - -/* - *---------------------------------------------------------------------- - * - * FormatNumber -- - * - * This routine is called by Tcl_BinaryObjCmd to format a number into a - * location pointed at by cursor. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Moves the cursor to the next location to be written into. - * - *---------------------------------------------------------------------- - */ - -static int -FormatNumber( - Tcl_Interp *interp, /* Current interpreter, used to report - * errors. */ - int type, /* Type of number to format. */ - Tcl_Obj *src, /* Number to format. */ - unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ -{ - long value; - double dvalue; - Tcl_WideInt wvalue; - float fvalue; - - switch (type) { - case 'd': - case 'q': - case 'Q': - /* - * Double-precision floating point values. Tcl_GetDoubleFromObj - * returns TCL_ERROR for NaN, but we can check by comparing the - * object's type pointer. - */ - - if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { - return TCL_ERROR; - } - dvalue = src->internalRep.doubleValue; - } - CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); - *cursorPtr += sizeof(double); - return TCL_OK; - - case 'f': - case 'r': - case 'R': - /* - * Single-precision floating point values. Tcl_GetDoubleFromObj - * returns TCL_ERROR for NaN, but we can check by comparing the - * object's type pointer. - */ - - if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { - return TCL_ERROR; - } - dvalue = src->internalRep.doubleValue; - } - - /* - * Because some compilers will generate floating point exceptions on - * an overflow cast (e.g. Borland), we restrict the values to the - * valid range for float. - */ - - if (fabs(dvalue) > (double)FLT_MAX) { - fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; - } else { - fvalue = (float) dvalue; - } - CopyNumber(&fvalue, *cursorPtr, sizeof(float), type); - *cursorPtr += sizeof(float); - return TCL_OK; - - /* - * 64-bit integer values. - */ - case 'w': - case 'W': - case 'm': - 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); - } 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); - } - return TCL_OK; - - /* - * 32-bit integer values. - */ - case 'i': - case 'I': - case 'n': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { - return TCL_ERROR; - } - if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 24); - } else { - *(*cursorPtr)++ = UCHAR(value >> 24); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); - } - return TCL_OK; - - /* - * 16-bit integer values. - */ - case 's': - case 'S': - case 't': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { - return TCL_ERROR; - } - if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); - } else { - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); - } - return TCL_OK; - - /* - * 8-bit integer values. - */ - case 'c': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { - return TCL_ERROR; - } - *(*cursorPtr)++ = UCHAR(value); - return TCL_OK; - - default: - Tcl_Panic("unexpected fallthrough"); - return TCL_ERROR; - } -} - -/* - *---------------------------------------------------------------------- - * - * ScanNumber -- - * - * This routine is called by Tcl_BinaryObjCmd to scan a number out of a - * buffer. - * - * Results: - * Returns a newly created object containing the scanned number. This - * object has a ref count of zero. - * - * Side effects: - * Might reuse an object in the number cache, place a new object in the - * cache, or delete the cache and set the reference to it (itself passed - * in by reference) to NULL. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -ScanNumber( - unsigned char *buffer, /* Buffer to scan number from. */ - 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. */ -{ - long value; - float fvalue; - double dvalue; - Tcl_WideUInt uwvalue; - - /* - * We cannot rely on the compiler to properly sign extend integer values - * when we cast from smaller values to larger values because we don't know - * the exact size of the integer types. So, we have to handle sign - * extension explicitly by checking the high bit and padding with 1's as - * needed. This practice is disabled if the BINARY_UNSIGNED flag is set. - */ - - switch (type) { - case 'c': - /* - * Characters need special handling. We want to produce a signed - * result, but on some platforms (such as AIX) chars are unsigned. To - * deal with this, check for a value that should be negative but - * isn't. - */ - - value = buffer[0]; - if (!(flags & BINARY_UNSIGNED)) { - if (value & 0x80) { - value |= -0x100; - } - } - goto returnNumericObject; - - /* - * 16-bit numeric values. We need the sign extension trick (see above) - * here as well. - */ - - case 's': - case 'S': - case 't': - if (NeedReversing(type)) { - value = (long) (buffer[0] + (buffer[1] << 8)); - } else { - value = (long) (buffer[1] + (buffer[0] << 8)); - } - if (!(flags & BINARY_UNSIGNED)) { - if (value & 0x8000) { - value |= -0x10000; - } - } - goto returnNumericObject; - - /* - * 32-bit numeric values. - */ - - case 'i': - case 'I': - case 'n': - if (NeedReversing(type)) { - value = (long) (buffer[0] - + (buffer[1] << 8) - + (buffer[2] << 16) - + (((long)buffer[3]) << 24)); - } else { - value = (long) (buffer[3] - + (buffer[2] << 8) - + (buffer[1] << 16) - + (((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). - */ - - if (flags & BINARY_UNSIGNED) { - return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value); - } - if ((value & (((unsigned) 1)<<31)) && (value > 0)) { - value -= (((unsigned) 1)<<31); - value -= (((unsigned) 1)<<31); - } - - returnNumericObject: - if (*numberCachePtrPtr == NULL) { - return Tcl_NewLongObj(value); - } else { - register Tcl_HashTable *tablePtr = *numberCachePtrPtr; - register Tcl_HashEntry *hPtr; - int isNew; - - hPtr = Tcl_CreateHashEntry(tablePtr, INT2PTR(value), &isNew); - if (!isNew) { - return Tcl_GetHashValue(hPtr); - } - if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - register Tcl_Obj *objPtr = Tcl_NewLongObj(value); - - Tcl_IncrRefCount(objPtr); - Tcl_SetHashValue(hPtr, objPtr); - return objPtr; - } - - /* - * We've overflowed the cache! Someone's parsing a LOT of varied - * binary data in a single call! Bail out by switching back to the - * old behaviour for the rest of the scan. - * - * Note that anyone just using the 'c' conversion (for bytes) - * cannot trigger this. - */ - - DeleteScanNumberCache(tablePtr); - *numberCachePtrPtr = NULL; - return Tcl_NewLongObj(value); - } - - /* - * Do not cache wide (64-bit) values; they are already too large to - * use as keys. - */ - - case 'w': - case 'W': - case 'm': - if (NeedReversing(type)) { - uwvalue = ((Tcl_WideUInt) buffer[0]) - | (((Tcl_WideUInt) buffer[1]) << 8) - | (((Tcl_WideUInt) buffer[2]) << 16) - | (((Tcl_WideUInt) buffer[3]) << 24) - | (((Tcl_WideUInt) buffer[4]) << 32) - | (((Tcl_WideUInt) buffer[5]) << 40) - | (((Tcl_WideUInt) buffer[6]) << 48) - | (((Tcl_WideUInt) buffer[7]) << 56); - } else { - uwvalue = ((Tcl_WideUInt) buffer[7]) - | (((Tcl_WideUInt) buffer[6]) << 8) - | (((Tcl_WideUInt) buffer[5]) << 16) - | (((Tcl_WideUInt) buffer[4]) << 24) - | (((Tcl_WideUInt) buffer[3]) << 32) - | (((Tcl_WideUInt) buffer[2]) << 40) - | (((Tcl_WideUInt) buffer[1]) << 48) - | (((Tcl_WideUInt) buffer[0]) << 56); - } - if (flags & BINARY_UNSIGNED) { - Tcl_Obj *bigObj = NULL; - mp_int big; - - TclBNInitBignumFromWideUInt(&big, uwvalue); - bigObj = Tcl_NewBignumObj(&big); - return bigObj; - } - return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); - - /* - * Do not cache double values; they are already too large to use as - * keys and the values stored are utterly incompatible with the - * integer part of the cache. - */ - - /* - * 32-bit IEEE single-precision floating point. - */ - - case 'f': - case 'R': - case 'r': - CopyNumber(buffer, &fvalue, sizeof(float), type); - return Tcl_NewDoubleObj(fvalue); - - /* - * 64-bit IEEE double-precision floating point. - */ - - case 'd': - case 'Q': - case 'q': - CopyNumber(buffer, &dvalue, sizeof(double), type); - return Tcl_NewDoubleObj(dvalue); - } - return NULL; -} - -/* - *---------------------------------------------------------------------- - * - * DeleteScanNumberCache -- - * - * Deletes the hash table acting as a scan number cache. - * - * Results: - * None - * - * Side effects: - * Decrements the reference counts of the objects in the cache. - * - *---------------------------------------------------------------------- - */ - -static void -DeleteScanNumberCache( - Tcl_HashTable *numberCachePtr) - /* Pointer to the hash table, or NULL (when - * the cache has already been deleted due to - * overflow.) */ -{ - Tcl_HashEntry *hEntry; - Tcl_HashSearch search; - - if (numberCachePtr == NULL) { - return; - } - - hEntry = Tcl_FirstHashEntry(numberCachePtr, &search); - while (hEntry != NULL) { - register Tcl_Obj *value = Tcl_GetHashValue(hEntry); - - if (value != NULL) { - Tcl_DecrRefCount(value); - } - hEntry = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(numberCachePtr); -} - -/* - * ---------------------------------------------------------------------- - * - * 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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj = NULL; - unsigned char *data = NULL; - unsigned char *cursor = NULL; - int 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( - ClientData clientData, - 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, size, count = 0, cut = 0, strict = 0; - 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); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc-1], &count); - 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((int) c)) { - if (strict || !isspace(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: - TclDecrRefCount(resultObj); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" at position %d", - c, (int) (data - datastart - 1))); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * BinaryEncode64 -- - * - * This implements a generic 6 bit binary encoding. Input is broken into - * 6 bit chunks and a lookup table passed in via clientData is used to - * turn these values into output characters. This is used to implement - * base64 binary encodings. - * - * Results: - * Interp result set to an encoded byte array object - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -#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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj; - unsigned char *data, *cursor, *limit; - int maxlen = 0; - const char *wrapchar = "\n"; - int wrapcharlen = 1; - int offset, i, index, 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_GetIntFromObj(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", NULL); - return TCL_ERROR; - } - break; - case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); - if (wrapcharlen == 0) { - maxlen = 0; - } - break; - } - } - - resultObj = Tcl_NewObj(); - data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); - if (count > 0) { - 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; - } - 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( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Tcl_Obj *resultObj; - unsigned char *data, *start, *cursor; - int offset, count, rawLength, n, i, j, bits, index; - int lineLength = 61; - const unsigned char SingleNewline[] = { (unsigned char) '\n' }; - const unsigned char *wrapchar = SingleNewline; - int 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 < 3 || lineLength > 85) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "line length out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", NULL); - return TCL_ERROR; - } - break; - case OPT_WRAPCHAR: - wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); - break; - } - } - - /* - * Allocate the buffer. This is a little bit too long, but is "good - * enough". - */ - - resultObj = Tcl_NewObj(); - 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) { - int 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( - ClientData clientData, - 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, size, count = 0, strict = 0, lineLen; - unsigned char c; - 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); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc-1], &count); - 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 || !isspace(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 (!isspace(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 || !isspace(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", NULL); - TclDecrRefCount(resultObj); - return TCL_ERROR; - - badUu: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" at position %d", - c, (int) (data - datastart - 1))); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", 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( - ClientData clientData, - 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 strict = 0; - int i, index, size, cut = 0, count = 0; - 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); - datastart = data = (unsigned char *) - TclGetStringFromObj(objv[objc-1], &count); - 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 { - 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 && isspace(c)) { - 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 == '=') { - value <<= 6; - cut++; - } else if (strict || !isspace(c)) { - 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; - } - for (; data < dataend; data++) { - if (!isspace(*data)) { - goto bad64; - } - } - } - } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; - - bad64: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" at position %d", - (char) c, (int) (data - datastart - 1))); - TclDecrRefCount(resultObj); - return TCL_ERROR; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ - |