sl@0: /* sl@0: * tclBinary.c -- sl@0: * sl@0: * This file contains the implementation of the "binary" Tcl built-in sl@0: * command and the Tcl binary data object. sl@0: * sl@0: * Copyright (c) 1997 by Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: #include sl@0: sl@0: /* sl@0: * The following constants are used by GetFormatSpec to indicate various sl@0: * special conditions in the parsing of a format specifier. sl@0: */ sl@0: sl@0: #define BINARY_ALL -1 /* Use all elements in the argument. */ sl@0: #define BINARY_NOCOUNT -2 /* No count was specified in format. */ sl@0: sl@0: /* sl@0: * The following defines the maximum number of different (integer) sl@0: * numbers placed in the object cache by 'binary scan' before it bails sl@0: * out and switches back to Plan A (creating a new object for each sl@0: * value.) Theoretically, it would be possible to keep the cache sl@0: * about for the values that are already in it, but that makes the sl@0: * code slower in practise when overflow happens, and makes little sl@0: * odds the rest of the time (as measured on my machine.) It is also sl@0: * slower (on the sample I tried at least) to grow the cache to hold sl@0: * all items we might want to put in it; presumably the extra cost of sl@0: * managing the memory for the enlarged table outweighs the benefit sl@0: * from allocating fewer objects. This is probably because as the sl@0: * number of objects increases, the likelihood of reuse of any sl@0: * particular one drops, and there is very little gain from larger sl@0: * maximum cache sizes (the value below is chosen to allow caching to sl@0: * work in full with conversion of bytes.) - DKF sl@0: */ sl@0: sl@0: #define BINARY_SCAN_MAX_CACHE 260 sl@0: sl@0: /* sl@0: * Prototypes for local procedures defined in this file: sl@0: */ sl@0: sl@0: static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, sl@0: Tcl_Obj *copyPtr)); sl@0: static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, sl@0: Tcl_Obj *src, unsigned char **cursorPtr)); sl@0: static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to, sl@0: unsigned int length)); sl@0: static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); sl@0: static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, sl@0: char *cmdPtr, int *countPtr)); sl@0: static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, sl@0: int type, Tcl_HashTable **numberCachePtr)); sl@0: static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); sl@0: static void DeleteScanNumberCache _ANSI_ARGS_(( sl@0: Tcl_HashTable *numberCachePtr)); sl@0: sl@0: /* sl@0: * The following object type represents an array of bytes. An array of sl@0: * bytes is not equivalent to an internationalized string. Conceptually, a sl@0: * string is an array of 16-bit quantities organized as a sequence of properly sl@0: * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities. sl@0: * Accessor functions are provided to convert a ByteArray to a String or a sl@0: * String to a ByteArray. Two or more consecutive bytes in an array of bytes sl@0: * may look like a single UTF-8 character if the array is casually treated as sl@0: * a string. But obtaining the String from a ByteArray is guaranteed to sl@0: * produced properly formed UTF-8 sequences so that there is a one-to-one sl@0: * map between bytes and characters. sl@0: * sl@0: * Converting a ByteArray to a String proceeds by casting each byte in the sl@0: * array to a 16-bit quantity, treating that number as a Unicode character, sl@0: * and storing the UTF-8 version of that Unicode character in the String. sl@0: * For ByteArrays consisting entirely of values 1..127, the corresponding sl@0: * String representation is the same as the ByteArray representation. sl@0: * sl@0: * Converting a String to a ByteArray proceeds by getting the Unicode sl@0: * representation of each character in the String, casting it to a sl@0: * byte by truncating the upper 8 bits, and then storing the byte in the sl@0: * ByteArray. Converting from ByteArray to String and back to ByteArray sl@0: * is not lossy, but converting an arbitrary String to a ByteArray may be. sl@0: */ sl@0: sl@0: Tcl_ObjType tclByteArrayType = { sl@0: "bytearray", sl@0: FreeByteArrayInternalRep, sl@0: DupByteArrayInternalRep, sl@0: UpdateStringOfByteArray, sl@0: SetByteArrayFromAny sl@0: }; sl@0: sl@0: /* sl@0: * The following structure is the internal rep for a ByteArray object. sl@0: * Keeps track of how much memory has been used and how much has been sl@0: * allocated for the byte array to enable growing and shrinking of the sl@0: * ByteArray object with fewer mallocs. sl@0: */ sl@0: sl@0: typedef struct ByteArray { sl@0: int used; /* The number of bytes used in the byte sl@0: * array. */ sl@0: int allocated; /* The amount of space actually allocated sl@0: * minus 1 byte. */ sl@0: unsigned char bytes[4]; /* The array of bytes. The actual size of sl@0: * this field depends on the 'allocated' field sl@0: * above. */ sl@0: } ByteArray; sl@0: sl@0: #define BYTEARRAY_SIZE(len) \ sl@0: ((unsigned) (sizeof(ByteArray) - 4 + (len))) sl@0: #define GET_BYTEARRAY(objPtr) \ sl@0: ((ByteArray *) (objPtr)->internalRep.otherValuePtr) sl@0: #define SET_BYTEARRAY(objPtr, baPtr) \ sl@0: (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr) sl@0: sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_NewByteArrayObj -- sl@0: * sl@0: * This procedure is creates a new ByteArray object and initializes sl@0: * it from the given array of bytes. sl@0: * sl@0: * Results: sl@0: * The newly create object is returned. This object will have no sl@0: * initial string representation. The returned object has a ref count sl@0: * of 0. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated for new object and copy of byte array argument. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: #undef Tcl_NewByteArrayObj sl@0: sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewByteArrayObj(bytes, length) sl@0: CONST unsigned char *bytes; /* The array of bytes used to initialize sl@0: * the new object. */ sl@0: int length; /* Length of the array of bytes, which must sl@0: * be >= 0. */ sl@0: { sl@0: return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_NewByteArrayObj(bytes, length) sl@0: CONST unsigned char *bytes; /* The array of bytes used to initialize sl@0: * the new object. */ sl@0: int length; /* Length of the array of bytes, which must sl@0: * be >= 0. */ sl@0: { sl@0: Tcl_Obj *objPtr; sl@0: sl@0: TclNewObj(objPtr); sl@0: Tcl_SetByteArrayObj(objPtr, bytes, length); sl@0: return objPtr; sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_DbNewByteArrayObj -- sl@0: * sl@0: * This procedure is normally called when debugging: i.e., when sl@0: * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj sl@0: * above except that it calls Tcl_DbCkalloc directly with the file name sl@0: * and line number from its caller. This simplifies debugging since then sl@0: * the [memory active] command will report the correct file name and line sl@0: * number when reporting objects that haven't been freed. sl@0: * sl@0: * When TCL_MEM_DEBUG is not defined, this procedure just returns the sl@0: * result of calling Tcl_NewByteArrayObj. sl@0: * sl@0: * Results: sl@0: * The newly create object is returned. This object will have no sl@0: * initial string representation. The returned object has a ref count sl@0: * of 0. sl@0: * sl@0: * Side effects: sl@0: * Memory allocated for new object and copy of byte array argument. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewByteArrayObj(bytes, length, file, line) sl@0: CONST unsigned char *bytes; /* The array of bytes used to initialize sl@0: * the new object. */ sl@0: int length; /* Length of the array of bytes, which must sl@0: * be >= 0. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: Tcl_Obj *objPtr; sl@0: sl@0: TclDbNewObj(objPtr, file, line); sl@0: Tcl_SetByteArrayObj(objPtr, bytes, length); sl@0: return objPtr; sl@0: } sl@0: sl@0: #else /* if not TCL_MEM_DEBUG */ sl@0: sl@0: EXPORT_C Tcl_Obj * sl@0: Tcl_DbNewByteArrayObj(bytes, length, file, line) sl@0: CONST unsigned char *bytes; /* The array of bytes used to initialize sl@0: * the new object. */ sl@0: int length; /* Length of the array of bytes, which must sl@0: * be >= 0. */ sl@0: CONST char *file; /* The name of the source file calling this sl@0: * procedure; used for debugging. */ sl@0: int line; /* Line number in the source file; used sl@0: * for debugging. */ sl@0: { sl@0: return Tcl_NewByteArrayObj(bytes, length); sl@0: } sl@0: #endif /* TCL_MEM_DEBUG */ sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetByteArrayObj -- sl@0: * sl@0: * Modify an object to be a ByteArray object and to have the specified sl@0: * array of bytes as its value. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's old string rep and internal rep is freed. sl@0: * Memory allocated for copy of byte array argument. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C void sl@0: Tcl_SetByteArrayObj(objPtr, bytes, length) sl@0: Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ sl@0: CONST unsigned char *bytes; /* The array of bytes to use as the new sl@0: * value. */ sl@0: int length; /* Length of the array of bytes, which must sl@0: * be >= 0. */ sl@0: { sl@0: Tcl_ObjType *typePtr; sl@0: ByteArray *byteArrayPtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetByteArrayObj called with shared object"); sl@0: } sl@0: typePtr = objPtr->typePtr; sl@0: if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { sl@0: (*typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: sl@0: byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); sl@0: byteArrayPtr->used = length; sl@0: byteArrayPtr->allocated = length; sl@0: memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length); sl@0: sl@0: objPtr->typePtr = &tclByteArrayType; sl@0: SET_BYTEARRAY(objPtr, byteArrayPtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_GetByteArrayFromObj -- sl@0: * sl@0: * Attempt to get the array of bytes from the Tcl object. If the sl@0: * object is not already a ByteArray object, an attempt will be sl@0: * made to convert it to one. sl@0: * sl@0: * Results: sl@0: * Pointer to array of bytes representing the ByteArray object. sl@0: * sl@0: * Side effects: sl@0: * Frees old internal rep. Allocates memory for new internal rep. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C unsigned char * sl@0: Tcl_GetByteArrayFromObj(objPtr, lengthPtr) sl@0: Tcl_Obj *objPtr; /* The ByteArray object. */ sl@0: int *lengthPtr; /* If non-NULL, filled with length of the sl@0: * array of bytes in the ByteArray object. */ sl@0: { sl@0: ByteArray *baPtr; sl@0: sl@0: SetByteArrayFromAny(NULL, objPtr); sl@0: baPtr = GET_BYTEARRAY(objPtr); sl@0: sl@0: if (lengthPtr != NULL) { sl@0: *lengthPtr = baPtr->used; sl@0: } sl@0: return (unsigned char *) baPtr->bytes; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_SetByteArrayLength -- sl@0: * sl@0: * This procedure changes the length of the byte array for this sl@0: * object. Once the caller has set the length of the array, it sl@0: * is acceptable to directly modify the bytes in the array up until sl@0: * Tcl_GetStringFromObj() has been called on this object. sl@0: * sl@0: * Results: sl@0: * The new byte array of the specified length. sl@0: * sl@0: * Side effects: sl@0: * Allocates enough memory for an array of bytes of the requested sl@0: * size. When growing the array, the old array is copied to the sl@0: * new array; new bytes are undefined. When shrinking, the sl@0: * old array is truncated to the specified length. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C unsigned char * sl@0: Tcl_SetByteArrayLength(objPtr, length) sl@0: Tcl_Obj *objPtr; /* The ByteArray object. */ sl@0: int length; /* New length for internal byte array. */ sl@0: { sl@0: ByteArray *byteArrayPtr, *newByteArrayPtr; sl@0: sl@0: if (Tcl_IsShared(objPtr)) { sl@0: panic("Tcl_SetObjLength called with shared object"); sl@0: } sl@0: if (objPtr->typePtr != &tclByteArrayType) { sl@0: SetByteArrayFromAny(NULL, objPtr); sl@0: } sl@0: sl@0: byteArrayPtr = GET_BYTEARRAY(objPtr); sl@0: if (length > byteArrayPtr->allocated) { sl@0: newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); sl@0: newByteArrayPtr->used = length; sl@0: newByteArrayPtr->allocated = length; sl@0: memcpy((VOID *) newByteArrayPtr->bytes, sl@0: (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used); sl@0: ckfree((char *) byteArrayPtr); sl@0: byteArrayPtr = newByteArrayPtr; sl@0: SET_BYTEARRAY(objPtr, byteArrayPtr); sl@0: } sl@0: Tcl_InvalidateStringRep(objPtr); sl@0: byteArrayPtr->used = length; sl@0: return byteArrayPtr->bytes; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * SetByteArrayFromAny -- sl@0: * sl@0: * Generate the ByteArray internal rep from the string rep. sl@0: * sl@0: * Results: sl@0: * The return value is always TCL_OK. sl@0: * sl@0: * Side effects: sl@0: * A ByteArray object is stored as the internal rep of objPtr. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: SetByteArrayFromAny(interp, objPtr) sl@0: Tcl_Interp *interp; /* Not used. */ sl@0: Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */ sl@0: { sl@0: Tcl_ObjType *typePtr; sl@0: int length; sl@0: char *src, *srcEnd; sl@0: unsigned char *dst; sl@0: ByteArray *byteArrayPtr; sl@0: Tcl_UniChar ch; sl@0: sl@0: typePtr = objPtr->typePtr; sl@0: if (typePtr != &tclByteArrayType) { sl@0: src = Tcl_GetStringFromObj(objPtr, &length); sl@0: srcEnd = src + length; sl@0: sl@0: byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); sl@0: for (dst = byteArrayPtr->bytes; src < srcEnd; ) { sl@0: src += Tcl_UtfToUniChar(src, &ch); sl@0: *dst++ = (unsigned char) ch; sl@0: } sl@0: sl@0: byteArrayPtr->used = dst - byteArrayPtr->bytes; sl@0: byteArrayPtr->allocated = length; sl@0: sl@0: if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) { sl@0: (*typePtr->freeIntRepProc)(objPtr); sl@0: } sl@0: objPtr->typePtr = &tclByteArrayType; sl@0: SET_BYTEARRAY(objPtr, byteArrayPtr); sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FreeByteArrayInternalRep -- sl@0: * sl@0: * Deallocate the storage associated with a ByteArray data object's sl@0: * internal representation. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Frees memory. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: FreeByteArrayInternalRep(objPtr) sl@0: Tcl_Obj *objPtr; /* Object with internal rep to free. */ sl@0: { sl@0: ckfree((char *) GET_BYTEARRAY(objPtr)); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * DupByteArrayInternalRep -- sl@0: * sl@0: * Initialize the internal representation of a ByteArray Tcl_Obj sl@0: * to a copy of the internal representation of an existing ByteArray sl@0: * object. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Allocates memory. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DupByteArrayInternalRep(srcPtr, copyPtr) sl@0: Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ sl@0: Tcl_Obj *copyPtr; /* Object with internal rep to set. */ sl@0: { sl@0: int length; sl@0: ByteArray *srcArrayPtr, *copyArrayPtr; sl@0: sl@0: srcArrayPtr = GET_BYTEARRAY(srcPtr); sl@0: length = srcArrayPtr->used; sl@0: sl@0: copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); sl@0: copyArrayPtr->used = length; sl@0: copyArrayPtr->allocated = length; sl@0: memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes, sl@0: (size_t) length); sl@0: SET_BYTEARRAY(copyPtr, copyArrayPtr); sl@0: sl@0: copyPtr->typePtr = &tclByteArrayType; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * UpdateStringOfByteArray -- sl@0: * sl@0: * Update the string representation for a ByteArray data object. sl@0: * Note: This procedure does not invalidate an existing old string rep sl@0: * so storage will be lost if this has not already been done. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The object's string is set to a valid string that results from sl@0: * the ByteArray-to-string conversion. sl@0: * sl@0: * The object becomes a string object -- the internal rep is sl@0: * discarded and the typePtr becomes NULL. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: UpdateStringOfByteArray(objPtr) sl@0: Tcl_Obj *objPtr; /* ByteArray object whose string rep to sl@0: * update. */ sl@0: { sl@0: int i, length, size; sl@0: unsigned char *src; sl@0: char *dst; sl@0: ByteArray *byteArrayPtr; sl@0: sl@0: byteArrayPtr = GET_BYTEARRAY(objPtr); sl@0: src = byteArrayPtr->bytes; sl@0: length = byteArrayPtr->used; sl@0: sl@0: /* sl@0: * How much space will string rep need? sl@0: */ sl@0: sl@0: size = length; sl@0: for (i = 0; i < length; i++) { sl@0: if ((src[i] == 0) || (src[i] > 127)) { sl@0: size++; sl@0: } sl@0: } sl@0: sl@0: dst = (char *) ckalloc((unsigned) (size + 1)); sl@0: objPtr->bytes = dst; sl@0: objPtr->length = size; sl@0: sl@0: if (size == length) { sl@0: memcpy((VOID *) dst, (VOID *) src, (size_t) size); sl@0: dst[size] = '\0'; sl@0: } else { sl@0: for (i = 0; i < length; i++) { sl@0: dst += Tcl_UniCharToUtf(src[i], dst); sl@0: } sl@0: *dst = '\0'; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Tcl_BinaryObjCmd -- sl@0: * sl@0: * This procedure implements the "binary" Tcl command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: Tcl_BinaryObjCmd(dummy, interp, objc, objv) sl@0: ClientData dummy; /* Not used. */ sl@0: Tcl_Interp *interp; /* Current interpreter. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument objects. */ sl@0: { sl@0: int arg; /* Index of next argument to consume. */ sl@0: int value = 0; /* Current integer value to be packed. sl@0: * Initialized to avoid compiler warning. */ sl@0: char cmd; /* Current format character. */ sl@0: int count; /* Count associated with current format sl@0: * character. */ sl@0: char *format; /* Pointer to current position in format sl@0: * string. */ sl@0: Tcl_Obj *resultPtr; /* Object holding result buffer. */ sl@0: unsigned char *buffer; /* Start of result buffer. */ sl@0: unsigned char *cursor; /* Current position within result buffer. */ sl@0: unsigned char *maxPos; /* Greatest position within result buffer that sl@0: * cursor has visited.*/ sl@0: char *errorString, *errorValue, *str; sl@0: int offset, size, length, index; sl@0: static CONST char *options[] = { sl@0: "format", "scan", NULL sl@0: }; sl@0: enum options { sl@0: BINARY_FORMAT, BINARY_SCAN sl@0: }; sl@0: sl@0: if (objc < 2) { sl@0: Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, sl@0: &index) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: switch ((enum options) index) { sl@0: case BINARY_FORMAT: { sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * To avoid copying the data, we format the string in two passes. sl@0: * The first pass computes the size of the output buffer. The sl@0: * second pass places the formatted data into the buffer. sl@0: */ sl@0: sl@0: format = Tcl_GetString(objv[2]); sl@0: arg = 3; sl@0: offset = 0; sl@0: length = 0; sl@0: while (*format != '\0') { sl@0: str = format; sl@0: if (!GetFormatSpec(&format, &cmd, &count)) { sl@0: break; sl@0: } sl@0: switch (cmd) { sl@0: case 'a': sl@0: case 'A': sl@0: case 'b': sl@0: case 'B': sl@0: case 'h': sl@0: case 'H': { sl@0: /* sl@0: * For string-type specifiers, the count corresponds sl@0: * to the number of bytes in a single argument. sl@0: */ sl@0: sl@0: if (arg >= objc) { sl@0: goto badIndex; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: Tcl_GetByteArrayFromObj(objv[arg], &count); sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: arg++; sl@0: if (cmd == 'a' || cmd == 'A') { sl@0: offset += count; sl@0: } else if (cmd == 'b' || cmd == 'B') { sl@0: offset += (count + 7) / 8; sl@0: } else { sl@0: offset += (count + 1) / 2; sl@0: } sl@0: break; sl@0: } sl@0: case 'c': { sl@0: size = 1; sl@0: goto doNumbers; sl@0: } sl@0: case 's': sl@0: case 'S': { sl@0: size = 2; sl@0: goto doNumbers; sl@0: } sl@0: case 'i': sl@0: case 'I': { sl@0: size = 4; sl@0: goto doNumbers; sl@0: } sl@0: case 'w': sl@0: case 'W': { sl@0: size = 8; sl@0: goto doNumbers; sl@0: } sl@0: case 'f': { sl@0: size = sizeof(float); sl@0: goto doNumbers; sl@0: } sl@0: case 'd': { sl@0: size = sizeof(double); sl@0: sl@0: doNumbers: sl@0: if (arg >= objc) { sl@0: goto badIndex; sl@0: } sl@0: sl@0: /* sl@0: * For number-type specifiers, the count corresponds sl@0: * to the number of elements in the list stored in sl@0: * a single argument. If no count is specified, then sl@0: * the argument is taken as a single non-list value. sl@0: */ sl@0: sl@0: if (count == BINARY_NOCOUNT) { sl@0: arg++; sl@0: count = 1; sl@0: } else { sl@0: int listc; sl@0: Tcl_Obj **listv; sl@0: if (Tcl_ListObjGetElements(interp, objv[arg++], sl@0: &listc, &listv) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: count = listc; sl@0: } else if (count > listc) { sl@0: Tcl_AppendResult(interp, sl@0: "number of elements in list does not match count", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: offset += count*size; sl@0: break; sl@0: } sl@0: case 'x': { sl@0: if (count == BINARY_ALL) { sl@0: Tcl_AppendResult(interp, sl@0: "cannot use \"*\" in format string with \"x\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: offset += count; sl@0: break; sl@0: } sl@0: case 'X': { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if ((count > offset) || (count == BINARY_ALL)) { sl@0: count = offset; sl@0: } sl@0: if (offset > length) { sl@0: length = offset; sl@0: } sl@0: offset -= count; sl@0: break; sl@0: } sl@0: case '@': { sl@0: if (offset > length) { sl@0: length = offset; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: offset = length; sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: goto badCount; sl@0: } else { sl@0: offset = count; sl@0: } sl@0: break; sl@0: } sl@0: default: { sl@0: errorString = str; sl@0: goto badField; sl@0: } sl@0: } sl@0: } sl@0: if (offset > length) { sl@0: length = offset; sl@0: } sl@0: if (length == 0) { sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: * Prepare the result object by preallocating the caclulated sl@0: * number of bytes and filling with nulls. sl@0: */ sl@0: sl@0: resultPtr = Tcl_GetObjResult(interp); sl@0: buffer = Tcl_SetByteArrayLength(resultPtr, length); sl@0: memset((VOID *) buffer, 0, (size_t) length); sl@0: sl@0: /* sl@0: * Pack the data into the result object. Note that we can skip sl@0: * the error checking during this pass, since we have already sl@0: * parsed the string once. sl@0: */ sl@0: sl@0: arg = 3; sl@0: format = Tcl_GetString(objv[2]); sl@0: cursor = buffer; sl@0: maxPos = cursor; sl@0: while (*format != 0) { sl@0: if (!GetFormatSpec(&format, &cmd, &count)) { sl@0: break; sl@0: } sl@0: if ((count == 0) && (cmd != '@')) { sl@0: arg++; sl@0: continue; sl@0: } sl@0: switch (cmd) { sl@0: case 'a': sl@0: case 'A': { sl@0: char pad = (char) (cmd == 'a' ? '\0' : ' '); sl@0: unsigned char *bytes; sl@0: sl@0: bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); sl@0: sl@0: if (count == BINARY_ALL) { sl@0: count = length; sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if (length >= count) { sl@0: memcpy((VOID *) cursor, (VOID *) bytes, sl@0: (size_t) count); sl@0: } else { sl@0: memcpy((VOID *) cursor, (VOID *) bytes, sl@0: (size_t) length); sl@0: memset((VOID *) (cursor + length), pad, sl@0: (size_t) (count - length)); sl@0: } sl@0: cursor += count; sl@0: break; sl@0: } sl@0: case 'b': sl@0: case 'B': { sl@0: unsigned char *last; sl@0: sl@0: str = Tcl_GetStringFromObj(objv[arg++], &length); sl@0: if (count == BINARY_ALL) { sl@0: count = length; sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: last = cursor + ((count + 7) / 8); sl@0: if (count > length) { sl@0: count = length; sl@0: } sl@0: value = 0; sl@0: errorString = "binary"; sl@0: if (cmd == 'B') { sl@0: for (offset = 0; offset < count; offset++) { sl@0: value <<= 1; sl@0: if (str[offset] == '1') { sl@0: value |= 1; sl@0: } else if (str[offset] != '0') { sl@0: errorValue = str; sl@0: goto badValue; sl@0: } sl@0: if (((offset + 1) % 8) == 0) { sl@0: *cursor++ = (unsigned char) value; sl@0: value = 0; sl@0: } sl@0: } sl@0: } else { sl@0: for (offset = 0; offset < count; offset++) { sl@0: value >>= 1; sl@0: if (str[offset] == '1') { sl@0: value |= 128; sl@0: } else if (str[offset] != '0') { sl@0: errorValue = str; sl@0: goto badValue; sl@0: } sl@0: if (!((offset + 1) % 8)) { sl@0: *cursor++ = (unsigned char) value; sl@0: value = 0; sl@0: } sl@0: } sl@0: } sl@0: if ((offset % 8) != 0) { sl@0: if (cmd == 'B') { sl@0: value <<= 8 - (offset % 8); sl@0: } else { sl@0: value >>= 8 - (offset % 8); sl@0: } sl@0: *cursor++ = (unsigned char) value; sl@0: } sl@0: while (cursor < last) { sl@0: *cursor++ = '\0'; sl@0: } sl@0: break; sl@0: } sl@0: case 'h': sl@0: case 'H': { sl@0: unsigned char *last; sl@0: int c; sl@0: sl@0: str = Tcl_GetStringFromObj(objv[arg++], &length); sl@0: if (count == BINARY_ALL) { sl@0: count = length; sl@0: } else if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: last = cursor + ((count + 1) / 2); sl@0: if (count > length) { sl@0: count = length; sl@0: } sl@0: value = 0; sl@0: errorString = "hexadecimal"; sl@0: if (cmd == 'H') { sl@0: for (offset = 0; offset < count; offset++) { sl@0: value <<= 4; sl@0: if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ sl@0: errorValue = str; sl@0: goto badValue; sl@0: } sl@0: c = str[offset] - '0'; sl@0: if (c > 9) { sl@0: c += ('0' - 'A') + 10; sl@0: } sl@0: if (c > 16) { sl@0: c += ('A' - 'a'); sl@0: } sl@0: value |= (c & 0xf); sl@0: if (offset % 2) { sl@0: *cursor++ = (char) value; sl@0: value = 0; sl@0: } sl@0: } sl@0: } else { sl@0: for (offset = 0; offset < count; offset++) { sl@0: value >>= 4; sl@0: sl@0: if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ sl@0: errorValue = str; sl@0: goto badValue; sl@0: } sl@0: c = str[offset] - '0'; sl@0: if (c > 9) { sl@0: c += ('0' - 'A') + 10; sl@0: } sl@0: if (c > 16) { sl@0: c += ('A' - 'a'); sl@0: } sl@0: value |= ((c << 4) & 0xf0); sl@0: if (offset % 2) { sl@0: *cursor++ = (unsigned char)(value & 0xff); sl@0: value = 0; sl@0: } sl@0: } sl@0: } sl@0: if (offset % 2) { sl@0: if (cmd == 'H') { sl@0: value <<= 4; sl@0: } else { sl@0: value >>= 4; sl@0: } sl@0: *cursor++ = (unsigned char) value; sl@0: } sl@0: sl@0: while (cursor < last) { sl@0: *cursor++ = '\0'; sl@0: } sl@0: break; sl@0: } sl@0: case 'c': sl@0: case 's': sl@0: case 'S': sl@0: case 'i': sl@0: case 'I': sl@0: case 'w': sl@0: case 'W': sl@0: case 'd': sl@0: case 'f': { sl@0: int listc, i; sl@0: Tcl_Obj **listv; sl@0: sl@0: if (count == BINARY_NOCOUNT) { sl@0: /* sl@0: * Note that we are casting away the const-ness of sl@0: * objv, but this is safe since we aren't going to sl@0: * modify the array. sl@0: */ sl@0: sl@0: listv = (Tcl_Obj**)(objv + arg); sl@0: listc = 1; sl@0: count = 1; sl@0: } else { sl@0: Tcl_ListObjGetElements(interp, objv[arg], sl@0: &listc, &listv); sl@0: if (count == BINARY_ALL) { sl@0: count = listc; sl@0: } sl@0: } sl@0: arg++; sl@0: for (i = 0; i < count; i++) { sl@0: if (FormatNumber(interp, cmd, listv[i], &cursor) sl@0: != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case 'x': { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: memset(cursor, 0, (size_t) count); sl@0: cursor += count; sl@0: break; sl@0: } sl@0: case 'X': { sl@0: if (cursor > maxPos) { sl@0: maxPos = cursor; sl@0: } sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if ((count == BINARY_ALL) sl@0: || (count > (cursor - buffer))) { sl@0: cursor = buffer; sl@0: } else { sl@0: cursor -= count; sl@0: } sl@0: break; sl@0: } sl@0: case '@': { sl@0: if (cursor > maxPos) { sl@0: maxPos = cursor; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: cursor = maxPos; sl@0: } else { sl@0: cursor = buffer + count; sl@0: } sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: break; sl@0: } sl@0: case BINARY_SCAN: { sl@0: int i; sl@0: Tcl_Obj *valuePtr, *elementPtr; sl@0: Tcl_HashTable numberCacheHash; sl@0: Tcl_HashTable *numberCachePtr; sl@0: sl@0: if (objc < 4) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "value formatString ?varName varName ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: numberCachePtr = &numberCacheHash; sl@0: Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); sl@0: buffer = Tcl_GetByteArrayFromObj(objv[2], &length); sl@0: format = Tcl_GetString(objv[3]); sl@0: cursor = buffer; sl@0: arg = 4; sl@0: offset = 0; sl@0: while (*format != '\0') { sl@0: str = format; sl@0: if (!GetFormatSpec(&format, &cmd, &count)) { sl@0: goto done; sl@0: } sl@0: switch (cmd) { sl@0: case 'a': sl@0: case 'A': { sl@0: unsigned char *src; sl@0: sl@0: if (arg >= objc) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: goto badIndex; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: count = length - offset; sl@0: } else { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if (count > (length - offset)) { sl@0: goto done; sl@0: } sl@0: } sl@0: sl@0: src = buffer + offset; sl@0: size = count; sl@0: sl@0: /* sl@0: * Trim trailing nulls and spaces, if necessary. sl@0: */ sl@0: sl@0: if (cmd == 'A') { sl@0: while (size > 0) { sl@0: if (src[size-1] != '\0' && src[size-1] != ' ') { sl@0: break; sl@0: } sl@0: size--; sl@0: } sl@0: } sl@0: valuePtr = Tcl_NewByteArrayObj(src, size); sl@0: Tcl_IncrRefCount(valuePtr); sl@0: resultPtr = Tcl_ObjSetVar2(interp, objv[arg], sl@0: NULL, valuePtr, TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(valuePtr); sl@0: arg++; sl@0: if (resultPtr == NULL) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: return TCL_ERROR; sl@0: } sl@0: offset += count; sl@0: break; sl@0: } sl@0: case 'b': sl@0: case 'B': { sl@0: unsigned char *src; sl@0: char *dest; sl@0: sl@0: if (arg >= objc) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: goto badIndex; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: count = (length - offset) * 8; sl@0: } else { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if (count > (length - offset) * 8) { sl@0: goto done; sl@0: } sl@0: } sl@0: src = buffer + offset; sl@0: valuePtr = Tcl_NewObj(); sl@0: Tcl_SetObjLength(valuePtr, count); sl@0: dest = Tcl_GetString(valuePtr); sl@0: sl@0: if (cmd == 'b') { sl@0: for (i = 0; i < count; i++) { sl@0: if (i % 8) { sl@0: value >>= 1; sl@0: } else { sl@0: value = *src++; sl@0: } sl@0: *dest++ = (char) ((value & 1) ? '1' : '0'); sl@0: } sl@0: } else { sl@0: for (i = 0; i < count; i++) { sl@0: if (i % 8) { sl@0: value <<= 1; sl@0: } else { sl@0: value = *src++; sl@0: } sl@0: *dest++ = (char) ((value & 0x80) ? '1' : '0'); sl@0: } sl@0: } sl@0: sl@0: Tcl_IncrRefCount(valuePtr); sl@0: resultPtr = Tcl_ObjSetVar2(interp, objv[arg], sl@0: NULL, valuePtr, TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(valuePtr); sl@0: arg++; sl@0: if (resultPtr == NULL) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: return TCL_ERROR; sl@0: } sl@0: offset += (count + 7 ) / 8; sl@0: break; sl@0: } sl@0: case 'h': sl@0: case 'H': { sl@0: char *dest; sl@0: unsigned char *src; sl@0: int i; sl@0: static char hexdigit[] = "0123456789abcdef"; sl@0: sl@0: if (arg >= objc) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: goto badIndex; sl@0: } sl@0: if (count == BINARY_ALL) { sl@0: count = (length - offset)*2; sl@0: } else { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if (count > (length - offset)*2) { sl@0: goto done; sl@0: } sl@0: } sl@0: src = buffer + offset; sl@0: valuePtr = Tcl_NewObj(); sl@0: Tcl_SetObjLength(valuePtr, count); sl@0: dest = Tcl_GetString(valuePtr); sl@0: sl@0: if (cmd == 'h') { sl@0: for (i = 0; i < count; i++) { sl@0: if (i % 2) { sl@0: value >>= 4; sl@0: } else { sl@0: value = *src++; sl@0: } sl@0: *dest++ = hexdigit[value & 0xf]; sl@0: } sl@0: } else { sl@0: for (i = 0; i < count; i++) { sl@0: if (i % 2) { sl@0: value <<= 4; sl@0: } else { sl@0: value = *src++; sl@0: } sl@0: *dest++ = hexdigit[(value >> 4) & 0xf]; sl@0: } sl@0: } sl@0: sl@0: Tcl_IncrRefCount(valuePtr); sl@0: resultPtr = Tcl_ObjSetVar2(interp, objv[arg], sl@0: NULL, valuePtr, TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(valuePtr); sl@0: arg++; sl@0: if (resultPtr == NULL) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: return TCL_ERROR; sl@0: } sl@0: offset += (count + 1) / 2; sl@0: break; sl@0: } sl@0: case 'c': { sl@0: size = 1; sl@0: goto scanNumber; sl@0: } sl@0: case 's': sl@0: case 'S': { sl@0: size = 2; sl@0: goto scanNumber; sl@0: } sl@0: case 'i': sl@0: case 'I': { sl@0: size = 4; sl@0: goto scanNumber; sl@0: } sl@0: case 'w': sl@0: case 'W': { sl@0: size = 8; sl@0: goto scanNumber; sl@0: } sl@0: case 'f': { sl@0: size = sizeof(float); sl@0: goto scanNumber; sl@0: } sl@0: case 'd': { sl@0: unsigned char *src; sl@0: sl@0: size = sizeof(double); sl@0: /* fall through */ sl@0: sl@0: scanNumber: sl@0: if (arg >= objc) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: goto badIndex; sl@0: } sl@0: if (count == BINARY_NOCOUNT) { sl@0: if ((length - offset) < size) { sl@0: goto done; sl@0: } sl@0: valuePtr = ScanNumber(buffer+offset, cmd, sl@0: &numberCachePtr); sl@0: offset += size; sl@0: } else { sl@0: if (count == BINARY_ALL) { sl@0: count = (length - offset) / size; sl@0: } sl@0: if ((length - offset) < (count * size)) { sl@0: goto done; sl@0: } sl@0: valuePtr = Tcl_NewObj(); sl@0: src = buffer+offset; sl@0: for (i = 0; i < count; i++) { sl@0: elementPtr = ScanNumber(src, cmd, sl@0: &numberCachePtr); sl@0: src += size; sl@0: Tcl_ListObjAppendElement(NULL, valuePtr, sl@0: elementPtr); sl@0: } sl@0: offset += count*size; sl@0: } sl@0: sl@0: Tcl_IncrRefCount(valuePtr); sl@0: resultPtr = Tcl_ObjSetVar2(interp, objv[arg], sl@0: NULL, valuePtr, TCL_LEAVE_ERR_MSG); sl@0: Tcl_DecrRefCount(valuePtr); sl@0: arg++; sl@0: if (resultPtr == NULL) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: return TCL_ERROR; sl@0: } sl@0: break; sl@0: } sl@0: case 'x': { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if ((count == BINARY_ALL) sl@0: || (count > (length - offset))) { sl@0: offset = length; sl@0: } else { sl@0: offset += count; sl@0: } sl@0: break; sl@0: } sl@0: case 'X': { sl@0: if (count == BINARY_NOCOUNT) { sl@0: count = 1; sl@0: } sl@0: if ((count == BINARY_ALL) || (count > offset)) { sl@0: offset = 0; sl@0: } else { sl@0: offset -= count; sl@0: } sl@0: break; sl@0: } sl@0: case '@': { sl@0: if (count == BINARY_NOCOUNT) { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: goto badCount; sl@0: } sl@0: if ((count == BINARY_ALL) || (count > length)) { sl@0: offset = length; sl@0: } else { sl@0: offset = count; sl@0: } sl@0: break; sl@0: } sl@0: default: { sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: errorString = str; sl@0: goto badField; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the result to the last position of the cursor. sl@0: */ sl@0: sl@0: done: sl@0: Tcl_ResetResult(interp); sl@0: Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); sl@0: DeleteScanNumberCache(numberCachePtr); sl@0: break; sl@0: } sl@0: } sl@0: return TCL_OK; sl@0: sl@0: badValue: sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString, sl@0: " string but got \"", errorValue, "\" instead", NULL); sl@0: return TCL_ERROR; sl@0: sl@0: badCount: sl@0: errorString = "missing count for \"@\" field specifier"; sl@0: goto error; sl@0: sl@0: badIndex: sl@0: errorString = "not enough arguments for all format specifiers"; sl@0: goto error; sl@0: sl@0: badField: sl@0: { sl@0: Tcl_UniChar ch; sl@0: char buf[TCL_UTF_MAX + 1]; sl@0: sl@0: Tcl_UtfToUniChar(errorString, &ch); sl@0: buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; sl@0: Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: error: sl@0: Tcl_AppendResult(interp, errorString, NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetFormatSpec -- sl@0: * sl@0: * This function parses the format strings used in the binary sl@0: * format and scan commands. sl@0: * sl@0: * Results: sl@0: * Moves the formatPtr to the start of the next command. Returns sl@0: * the current command character and count in cmdPtr and countPtr. sl@0: * The count is set to BINARY_ALL if the count character was '*' sl@0: * or BINARY_NOCOUNT if no count was specified. Returns 1 on sl@0: * success, or 0 if the string did not have a format specifier. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: GetFormatSpec(formatPtr, cmdPtr, countPtr) sl@0: char **formatPtr; /* Pointer to format string. */ sl@0: char *cmdPtr; /* Pointer to location of command char. */ sl@0: int *countPtr; /* Pointer to repeat count value. */ sl@0: { sl@0: /* sl@0: * Skip any leading blanks. sl@0: */ sl@0: sl@0: while (**formatPtr == ' ') { sl@0: (*formatPtr)++; sl@0: } sl@0: sl@0: /* sl@0: * The string was empty, except for whitespace, so fail. sl@0: */ sl@0: sl@0: if (!(**formatPtr)) { sl@0: return 0; sl@0: } sl@0: sl@0: /* sl@0: * Extract the command character and any trailing digits or '*'. sl@0: */ sl@0: sl@0: *cmdPtr = **formatPtr; sl@0: (*formatPtr)++; sl@0: if (**formatPtr == '*') { sl@0: (*formatPtr)++; sl@0: (*countPtr) = BINARY_ALL; sl@0: } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ sl@0: (*countPtr) = strtoul(*formatPtr, formatPtr, 10); sl@0: } else { sl@0: (*countPtr) = BINARY_NOCOUNT; sl@0: } sl@0: return 1; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * FormatNumber -- sl@0: * sl@0: * This routine is called by Tcl_BinaryObjCmd to format a number sl@0: * into a location pointed at by cursor. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Moves the cursor to the next location to be written into. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: FormatNumber(interp, type, src, cursorPtr) sl@0: Tcl_Interp *interp; /* Current interpreter, used to report sl@0: * errors. */ sl@0: int type; /* Type of number to format. */ sl@0: Tcl_Obj *src; /* Number to format. */ sl@0: unsigned char **cursorPtr; /* Pointer to index into destination buffer. */ sl@0: { sl@0: long value; sl@0: double dvalue; sl@0: Tcl_WideInt wvalue; sl@0: sl@0: switch (type) { sl@0: case 'd': sl@0: case 'f': sl@0: /* sl@0: * For floating point types, we need to copy the data using sl@0: * memcpy to avoid alignment issues. sl@0: */ sl@0: sl@0: if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (type == 'd') { sl@0: /* sl@0: * Can't just memcpy() here. [Bug 1116542] sl@0: */ sl@0: sl@0: CopyNumber(&dvalue, *cursorPtr, sizeof(double)); sl@0: *cursorPtr += sizeof(double); sl@0: } else { sl@0: float fvalue; sl@0: sl@0: /* sl@0: * Because some compilers will generate floating point exceptions sl@0: * on an overflow cast (e.g. Borland), we restrict the values sl@0: * to the valid range for float. sl@0: */ sl@0: sl@0: if (fabs(dvalue) > (double)FLT_MAX) { sl@0: fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX; sl@0: } else { sl@0: fvalue = (float) dvalue; sl@0: } sl@0: memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); sl@0: *cursorPtr += sizeof(float); sl@0: } sl@0: return TCL_OK; sl@0: sl@0: /* sl@0: * Next cases separate from other integer cases because we sl@0: * need a different API to get a wide. sl@0: */ sl@0: case 'w': sl@0: case 'W': sl@0: if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (type == 'w') { sl@0: *(*cursorPtr)++ = (unsigned char) wvalue; sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); sl@0: } else { sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); sl@0: *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); sl@0: *(*cursorPtr)++ = (unsigned char) wvalue; sl@0: } sl@0: return TCL_OK; sl@0: default: sl@0: if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (type == 'c') { sl@0: *(*cursorPtr)++ = (unsigned char) value; sl@0: } else if (type == 's') { sl@0: *(*cursorPtr)++ = (unsigned char) value; sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 8); sl@0: } else if (type == 'S') { sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 8); sl@0: *(*cursorPtr)++ = (unsigned char) value; sl@0: } else if (type == 'i') { sl@0: *(*cursorPtr)++ = (unsigned char) value; sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 8); sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 16); sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 24); sl@0: } else if (type == 'I') { sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 24); sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 16); sl@0: *(*cursorPtr)++ = (unsigned char) (value >> 8); sl@0: *(*cursorPtr)++ = (unsigned char) value; sl@0: } sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* Ugly workaround for old and broken compiler! */ sl@0: static void sl@0: CopyNumber(from, to, length) sl@0: CONST VOID *from; sl@0: VOID *to; sl@0: unsigned int length; sl@0: { sl@0: memcpy(to, from, length); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ScanNumber -- sl@0: * sl@0: * This routine is called by Tcl_BinaryObjCmd to scan a number sl@0: * out of a buffer. sl@0: * sl@0: * Results: sl@0: * Returns a newly created object containing the scanned number. sl@0: * This object has a ref count of zero. sl@0: * sl@0: * Side effects: sl@0: * Might reuse an object in the number cache, place a new object sl@0: * in the cache, or delete the cache and set the reference to sl@0: * it (itself passed in by reference) to NULL. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Obj * sl@0: ScanNumber(buffer, type, numberCachePtrPtr) sl@0: unsigned char *buffer; /* Buffer to scan number from. */ sl@0: int type; /* Format character from "binary scan" */ sl@0: Tcl_HashTable **numberCachePtrPtr; sl@0: /* Place to look for cache of scanned sl@0: * value objects, or NULL if too many sl@0: * different numbers have been scanned. */ sl@0: { sl@0: long value; sl@0: Tcl_WideUInt uwvalue; sl@0: sl@0: /* sl@0: * We cannot rely on the compiler to properly sign extend integer values sl@0: * when we cast from smaller values to larger values because we don't know sl@0: * the exact size of the integer types. So, we have to handle sign sl@0: * extension explicitly by checking the high bit and padding with 1's as sl@0: * needed. sl@0: */ sl@0: sl@0: switch (type) { sl@0: case 'c': sl@0: /* sl@0: * Characters need special handling. We want to produce a sl@0: * signed result, but on some platforms (such as AIX) chars sl@0: * are unsigned. To deal with this, check for a value that sl@0: * should be negative but isn't. sl@0: */ sl@0: sl@0: value = buffer[0]; sl@0: if (value & 0x80) { sl@0: value |= -0x100; sl@0: } sl@0: goto returnNumericObject; sl@0: sl@0: case 's': sl@0: value = (long) (buffer[0] + (buffer[1] << 8)); sl@0: goto shortValue; sl@0: case 'S': sl@0: value = (long) (buffer[1] + (buffer[0] << 8)); sl@0: shortValue: sl@0: if (value & 0x8000) { sl@0: value |= -0x10000; sl@0: } sl@0: goto returnNumericObject; sl@0: sl@0: case 'i': sl@0: value = (long) (buffer[0] sl@0: + (buffer[1] << 8) sl@0: + (buffer[2] << 16) sl@0: + (buffer[3] << 24)); sl@0: goto intValue; sl@0: case 'I': sl@0: value = (long) (buffer[3] sl@0: + (buffer[2] << 8) sl@0: + (buffer[1] << 16) sl@0: + (buffer[0] << 24)); sl@0: intValue: sl@0: /* sl@0: * Check to see if the value was sign extended properly on sl@0: * systems where an int is more than 32-bits. sl@0: */ sl@0: sl@0: if ((value & (((unsigned int)1)<<31)) && (value > 0)) { sl@0: value -= (((unsigned int)1)<<31); sl@0: value -= (((unsigned int)1)<<31); sl@0: } sl@0: returnNumericObject: sl@0: if (*numberCachePtrPtr == NULL) { sl@0: return Tcl_NewLongObj(value); sl@0: } else { sl@0: register Tcl_HashTable *tablePtr = *numberCachePtrPtr; sl@0: register Tcl_HashEntry *hPtr; sl@0: int isNew; sl@0: sl@0: hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); sl@0: if (!isNew) { sl@0: return (Tcl_Obj *) Tcl_GetHashValue(hPtr); sl@0: } sl@0: if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { sl@0: /* sl@0: * We've overflowed the cache! Someone's parsing sl@0: * a LOT of varied binary data in a single call! sl@0: * Bail out by switching back to the old behaviour sl@0: * for the rest of the scan. sl@0: * sl@0: * Note that anyone just using the 'c' conversion sl@0: * (for bytes) cannot trigger this. sl@0: */ sl@0: DeleteScanNumberCache(tablePtr); sl@0: *numberCachePtrPtr = NULL; sl@0: return Tcl_NewLongObj(value); sl@0: } else { sl@0: register Tcl_Obj *objPtr = Tcl_NewLongObj(value); sl@0: sl@0: Tcl_IncrRefCount(objPtr); sl@0: Tcl_SetHashValue(hPtr, (ClientData) objPtr); sl@0: return objPtr; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Do not cache wide values; they are already too large to sl@0: * use as keys. sl@0: */ sl@0: case 'w': sl@0: uwvalue = ((Tcl_WideUInt) buffer[0]) sl@0: | (((Tcl_WideUInt) buffer[1]) << 8) sl@0: | (((Tcl_WideUInt) buffer[2]) << 16) sl@0: | (((Tcl_WideUInt) buffer[3]) << 24) sl@0: | (((Tcl_WideUInt) buffer[4]) << 32) sl@0: | (((Tcl_WideUInt) buffer[5]) << 40) sl@0: | (((Tcl_WideUInt) buffer[6]) << 48) sl@0: | (((Tcl_WideUInt) buffer[7]) << 56); sl@0: return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); sl@0: case 'W': sl@0: uwvalue = ((Tcl_WideUInt) buffer[7]) sl@0: | (((Tcl_WideUInt) buffer[6]) << 8) sl@0: | (((Tcl_WideUInt) buffer[5]) << 16) sl@0: | (((Tcl_WideUInt) buffer[4]) << 24) sl@0: | (((Tcl_WideUInt) buffer[3]) << 32) sl@0: | (((Tcl_WideUInt) buffer[2]) << 40) sl@0: | (((Tcl_WideUInt) buffer[1]) << 48) sl@0: | (((Tcl_WideUInt) buffer[0]) << 56); sl@0: return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue); sl@0: sl@0: /* sl@0: * Do not cache double values; they are already too large sl@0: * to use as keys and the values stored are utterly sl@0: * incompatible too. sl@0: */ sl@0: case 'f': { sl@0: float fvalue; sl@0: memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); sl@0: return Tcl_NewDoubleObj(fvalue); sl@0: } sl@0: case 'd': { sl@0: double dvalue; sl@0: memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double)); sl@0: return Tcl_NewDoubleObj(dvalue); sl@0: } sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * DeleteScanNumberCache -- sl@0: * sl@0: * Deletes the hash table acting as a scan number cache. sl@0: * sl@0: * Results: sl@0: * None sl@0: * sl@0: * Side effects: sl@0: * Decrements the reference counts of the objects in the cache. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: DeleteScanNumberCache(numberCachePtr) sl@0: Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or sl@0: * NULL (when the cache has already sl@0: * been deleted due to overflow.) */ sl@0: { sl@0: Tcl_HashEntry *hEntry; sl@0: Tcl_HashSearch search; sl@0: sl@0: if (numberCachePtr == NULL) { sl@0: return; sl@0: } sl@0: sl@0: hEntry = Tcl_FirstHashEntry(numberCachePtr, &search); sl@0: while (hEntry != NULL) { sl@0: register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry); sl@0: sl@0: if (value != NULL) { sl@0: Tcl_DecrRefCount(value); sl@0: } sl@0: hEntry = Tcl_NextHashEntry(&search); sl@0: } sl@0: Tcl_DeleteHashTable(numberCachePtr); sl@0: }