/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclbinary.c,v 1.1.1.1 2001/06/13 04:33:55 dtashley Exp $ */ /* * 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. * * RCS: @(#) $Id: tclbinary.c,v 1.1.1.1 2001/06/13 04:33:55 dtashley Exp $ */ #include #include "tclInt.h" #include "tclPort.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. */ /* * Prototypes for local procedures defined in this file: */ static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr)); static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); /* * 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. */ 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[4]; /* The array of bytes. The actual size of * this field depends on the 'allocated' field * above. */ } ByteArray; #define BYTEARRAY_SIZE(len) \ ((unsigned) (sizeof(ByteArray) - 4 + (len))) #define GET_BYTEARRAY(objPtr) \ ((ByteArray *) (objPtr)->internalRep.otherValuePtr) #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.otherValuePtr = (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. * *--------------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewByteArrayObj Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ { return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ { Tcl_Obj *objPtr; TclNewObj(objPtr); Tcl_SetByteArrayObj(objPtr, bytes, 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 checkmem 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. * *--------------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) 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. */ 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. */ { Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); Tcl_SetByteArrayObj(objPtr, bytes, length); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) 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. */ char *file; /* The name of the source file calling this * procedure; used for debugging. */ int line; /* Line number in the source file; used * for debugging. */ { return Tcl_NewByteArrayObj(bytes, 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(objPtr, bytes, length) Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ unsigned char *bytes; /* The array of bytes to use as the new * value. */ int length; /* Length of the array of bytes, which must * be >= 0. */ { Tcl_ObjType *typePtr; ByteArray *byteArrayPtr; if (Tcl_IsShared(objPtr)) { panic("Tcl_SetByteArrayObj called with shared object"); } typePtr = objPtr->typePtr; if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) { (*typePtr->freeIntRepProc)(objPtr); } Tcl_InvalidateStringRep(objPtr); byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); byteArrayPtr->used = length; byteArrayPtr->allocated = length; memcpy((VOID *) byteArrayPtr->bytes, (VOID *) 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(objPtr, lengthPtr) 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; 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(objPtr, length) Tcl_Obj *objPtr; /* The ByteArray object. */ int length; /* New length for internal byte array. */ { ByteArray *byteArrayPtr, *newByteArrayPtr; if (Tcl_IsShared(objPtr)) { panic("Tcl_SetObjLength called with shared object"); } if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); if (length > byteArrayPtr->allocated) { newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); newByteArrayPtr->used = length; newByteArrayPtr->allocated = length; memcpy((VOID *) newByteArrayPtr->bytes, (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used); ckfree((char *) byteArrayPtr); byteArrayPtr = newByteArrayPtr; SET_BYTEARRAY(objPtr, byteArrayPtr); } Tcl_InvalidateStringRep(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(interp, objPtr) Tcl_Interp *interp; /* Not used. */ Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */ { Tcl_ObjType *typePtr; int length; char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; typePtr = objPtr->typePtr; if (typePtr != &tclByteArrayType) { src = Tcl_GetStringFromObj(objPtr, &length); srcEnd = src + length; byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); for (dst = byteArrayPtr->bytes; src < srcEnd; ) { src += Tcl_UtfToUniChar(src, &ch); *dst++ = (unsigned char) ch; } byteArrayPtr->used = dst - byteArrayPtr->bytes; byteArrayPtr->allocated = length; if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) { (*typePtr->freeIntRepProc)(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(objPtr) Tcl_Obj *objPtr; /* Object with internal rep to free. */ { ckfree((char *) GET_BYTEARRAY(objPtr)); } /* *--------------------------------------------------------------------------- * * 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(srcPtr, copyPtr) 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 = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy((VOID *) copyArrayPtr->bytes, (VOID *) 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(objPtr) 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; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } dst = (char *) ckalloc((unsigned) (size + 1)); objPtr->bytes = dst; objPtr->length = size; if (size == length) { memcpy((VOID *) dst, (VOID *) src, (size_t) size); dst[size] = '\0'; } else { for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } *dst = '\0'; } } /* *---------------------------------------------------------------------- * * Tcl_BinaryObjCmd -- * * This procedure implements the "binary" Tcl command. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_BinaryObjCmd(dummy, interp, objc, objv) 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. */ char *format; /* Pointer to current position in format * string. */ Tcl_Obj *resultPtr; /* 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.*/ char *errorString, *errorValue, *str; int offset, size, length, index; static char *options[] = { "format", "scan", NULL }; enum options { BINARY_FORMAT, BINARY_SCAN }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case BINARY_FORMAT: { if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } /* * To avoid copying the data, we format the string in two passes. * The first pass computes the size of the output buffer. The * second pass places the formatted data into the buffer. */ format = Tcl_GetString(objv[2]); arg = 3; offset = 0; length = 0; while (*format != '\0') { str = format; if (!GetFormatSpec(&format, &cmd, &count)) { break; } switch (cmd) { case 'a': case 'A': case 'b': case 'B': case 'h': case 'H': { /* * For string-type specifiers, the count corresponds * to the number of bytes in a single argument. */ 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 's': case 'S': { size = 2; goto doNumbers; } case 'i': case 'I': { size = 4; goto doNumbers; } case 'f': { size = sizeof(float); goto doNumbers; } 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; if (Tcl_ListObjGetElements(interp, objv[arg++], &listc, &listv) != TCL_OK) { return TCL_ERROR; } if (count == BINARY_ALL) { count = listc; } else if (count > listc) { Tcl_AppendResult(interp, "number of elements in list does not match count", (char *) NULL); return TCL_ERROR; } } offset += count*size; break; } case 'x': { if (count == BINARY_ALL) { Tcl_AppendResult(interp, "cannot use \"*\" in format string with \"x\"", (char *) NULL); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; } offset += count; break; } case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } if ((count > offset) || (count == BINARY_ALL)) { count = offset; } if (offset > length) { length = offset; } offset -= count; break; } case '@': { if (offset > length) { length = offset; } if (count == BINARY_ALL) { offset = length; } else if (count == BINARY_NOCOUNT) { goto badCount; } else { offset = count; } break; } 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_GetObjResult(interp); buffer = Tcl_SetByteArrayLength(resultPtr, length); memset((VOID *) buffer, 0, (size_t) length); /* * Pack the data into the result object. Note that we can skip * the error checking during this pass, since we have already * parsed the string once. */ arg = 3; format = Tcl_GetString(objv[2]); cursor = buffer; maxPos = cursor; while (*format != 0) { if (!GetFormatSpec(&format, &cmd, &count)) { break; } if ((count == 0) && (cmd != '@')) { 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((VOID *) cursor, (VOID *) bytes, (size_t) count); } else { memcpy((VOID *) cursor, (VOID *) bytes, (size_t) length); memset((VOID *) (cursor + length), pad, (size_t) (count - length)); } cursor += count; break; } case 'b': case 'B': { unsigned char *last; str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } last = cursor + ((count + 7) / 8); if (count > length) { count = length; } value = 0; errorString = "binary"; if (cmd == 'B') { for (offset = 0; offset < count; offset++) { value <<= 1; if (str[offset] == '1') { value |= 1; } else if (str[offset] != '0') { errorValue = str; goto badValue; } if (((offset + 1) % 8) == 0) { *cursor++ = (unsigned char) value; value = 0; } } } else { for (offset = 0; offset < count; offset++) { value >>= 1; if (str[offset] == '1') { value |= 128; } else if (str[offset] != '0') { errorValue = str; goto badValue; } if (!((offset + 1) % 8)) { *cursor++ = (unsigned char) value; value = 0; } } } if ((offset % 8) != 0) { if (cmd == 'B') { value <<= 8 - (offset % 8); } else { value >>= 8 - (offset % 8); } *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; } break; } case 'h': case 'H': { unsigned char *last; int c; str = Tcl_GetStringFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { count = 1; } last = cursor + ((count + 1) / 2); if (count > length) { count = length; } value = 0; errorString = "hexadecimal"; if (cmd == 'H') { for (offset = 0; offset < count; offset++) { value <<= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } c = str[offset] - '0'; if (c > 9) { c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } value |= (c & 0xf); if (offset % 2) { *cursor++ = (char) value; value = 0; } } } else { for (offset = 0; offset < count; offset++) { value >>= 4; if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */ errorValue = str; goto badValue; } c = str[offset] - '0'; if (c > 9) { c += ('0' - 'A') + 10; } if (c > 16) { c += ('A' - 'a'); } value |= ((c << 4) & 0xf0); if (offset % 2) { *cursor++ = (unsigned char)(value & 0xff); value = 0; } } } if (offset % 2) { if (cmd == 'H') { value <<= 4; } else { value >>= 4; } *cursor++ = (unsigned char) value; } while (cursor < last) { *cursor++ = '\0'; } break; } case 'c': case 's': case 'S': case 'i': case 'I': case 'd': case 'f': { int listc, i; Tcl_Obj **listv; if (count == BINARY_NOCOUNT) { /* * Note that we are casting away the const-ness of * objv, but this is safe since we aren't going to * modify the array. */ listv = (Tcl_Obj**)(objv + arg); listc = 1; count = 1; } else { Tcl_ListObjGetElements(interp, objv[arg], &listc, &listv); if (count == BINARY_ALL) { count = listc; } } arg++; for (i = 0; i < count; i++) { if (FormatNumber(interp, cmd, listv[i], &cursor) != TCL_OK) { return TCL_ERROR; } } break; } case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } memset(cursor, 0, (size_t) count); cursor += count; break; } case 'X': { if (cursor > maxPos) { maxPos = cursor; } if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > (cursor - buffer))) { cursor = buffer; } else { cursor -= count; } break; } case '@': { if (cursor > maxPos) { maxPos = cursor; } if (count == BINARY_ALL) { cursor = maxPos; } else { cursor = buffer + count; } break; } } } break; } case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "value formatString ?varName varName ...?"); return TCL_ERROR; } buffer = Tcl_GetByteArrayFromObj(objv[2], &length); format = Tcl_GetString(objv[3]); cursor = buffer; arg = 4; offset = 0; while (*format != '\0') { str = format; if (!GetFormatSpec(&format, &cmd, &count)) { goto done; } switch (cmd) { case 'a': case 'A': { unsigned char *src; if (arg >= objc) { 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--; } } valuePtr = Tcl_NewByteArrayObj(src, size); resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += count; break; } case 'b': case 'B': { unsigned char *src; char *dest; if (arg >= objc) { goto badIndex; } if (count == BINARY_ALL) { count = (length - offset) * 8; } else { if (count == BINARY_NOCOUNT) { count = 1; } if (count > (length - offset) * 8) { goto done; } } src = buffer + offset; valuePtr = Tcl_NewObj(); Tcl_SetObjLength(valuePtr, count); dest = Tcl_GetString(valuePtr); if (cmd == 'b') { for (i = 0; i < count; i++) { if (i % 8) { value >>= 1; } else { value = *src++; } *dest++ = (char) ((value & 1) ? '1' : '0'); } } else { for (i = 0; i < count; i++) { if (i % 8) { value <<= 1; } else { value = *src++; } *dest++ = (char) ((value & 0x80) ? '1' : '0'); } } resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 7 ) / 8; break; } case 'h': case 'H': { char *dest; unsigned char *src; int i; static char hexdigit[] = "0123456789abcdef"; if (arg >= objc) { 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 = Tcl_GetString(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) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } offset += (count + 1) / 2; break; } case 'c': { size = 1; goto scanNumber; } case 's': case 'S': { size = 2; goto scanNumber; } case 'i': case 'I': { size = 4; goto scanNumber; } case 'f': { size = sizeof(float); goto scanNumber; } case 'd': { unsigned char *src; size = sizeof(double); /* fall through */ scanNumber: if (arg >= objc) { goto badIndex; } if (count == BINARY_NOCOUNT) { if ((length - offset) < size) { goto done; } valuePtr = ScanNumber(buffer+offset, cmd); 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); 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) { Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } break; } case 'x': { if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > (length - offset))) { offset = length; } else { offset += count; } break; } case 'X': { if (count == BINARY_NOCOUNT) { count = 1; } if ((count == BINARY_ALL) || (count > offset)) { offset = 0; } else { offset -= count; } break; } case '@': { if (count == BINARY_NOCOUNT) { goto badCount; } if ((count == BINARY_ALL) || (count > length)) { offset = length; } else { offset = count; } break; } default: { errorString = str; goto badfield; } } } /* * Set the result to the last position of the cursor. */ done: Tcl_ResetResult(interp); Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); break; } } return TCL_OK; badValue: Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString, " string but got \"", errorValue, "\" instead", NULL); 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_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } error: Tcl_AppendResult(interp, errorString, NULL); 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(formatPtr, cmdPtr, countPtr) char **formatPtr; /* Pointer to format string. */ char *cmdPtr; /* Pointer to location of command char. */ int *countPtr; /* Pointer to repeat count value. */ { /* * 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 == '*') { (*formatPtr)++; (*countPtr) = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ (*countPtr) = strtoul(*formatPtr, formatPtr, 10); } else { (*countPtr) = BINARY_NOCOUNT; } return 1; } /* *---------------------------------------------------------------------- * * 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(interp, type, src, cursorPtr) 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. */ { int value; double dvalue; if ((type == 'd') || (type == 'f')) { /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { return TCL_ERROR; } if (type == 'd') { memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double)); *cursorPtr += sizeof(double); } else { float fvalue; /* * 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; } memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); *cursorPtr += sizeof(float); } } else { if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (type == 'c') { *(*cursorPtr)++ = (unsigned char) value; } else if (type == 's') { *(*cursorPtr)++ = (unsigned char) value; *(*cursorPtr)++ = (unsigned char) (value >> 8); } else if (type == 'S') { *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) value; } else if (type == 'i') { *(*cursorPtr)++ = (unsigned char) value; *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) (value >> 16); *(*cursorPtr)++ = (unsigned char) (value >> 24); } else if (type == 'I') { *(*cursorPtr)++ = (unsigned char) (value >> 24); *(*cursorPtr)++ = (unsigned char) (value >> 16); *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) value; } } return TCL_OK; } /* *---------------------------------------------------------------------- * * 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: * None. * *---------------------------------------------------------------------- */ static Tcl_Obj * ScanNumber(buffer, type) unsigned char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ { long value; /* * 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. */ 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 (value & 0x80) { value |= -0x100; } return Tcl_NewLongObj((long)value); } case 's': { value = (long) (buffer[0] + (buffer[1] << 8)); goto shortValue; } case 'S': { value = (long) (buffer[1] + (buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } return Tcl_NewLongObj(value); } case 'i': { value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); goto intValue; } case 'I': { value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) + (buffer[0] << 24)); intValue: /* * Check to see if the value was sign extended properly on * systems where an int is more than 32-bits. */ if ((value & (((unsigned int)1)<<31)) && (value > 0)) { value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } return Tcl_NewLongObj(value); } case 'f': { float fvalue; memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); return Tcl_NewDoubleObj(fvalue); } case 'd': { double dvalue; memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double)); return Tcl_NewDoubleObj(dvalue); } } return NULL; } /* $History: tclbinary.c $ * * ***************** Version 1 ***************** * User: Dtashley Date: 1/02/01 Time: 1:35a * Created in $/IjuScripter, IjuConsole/Source/Tcl Base * Initial check-in. */ /* End of TCLBINARY.C */