/*
* 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.41.2.1 2010/04/30 20:59:20 dgp Exp $
*/
#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(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 int length, int type);
/*
* The following object type represents an array of bytes. An array of bytes
* is not equivalent to an internationalized string. Conceptually, a string is
* an array of 16-bit quantities organized as a sequence of properly formed
* UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
* 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(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length) /* Length of the array of bytes, which must be
* >= 0. */
{
return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_NewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length) /* Length of the array of bytes, which must be
* >= 0. */
{
Tcl_Obj *objPtr;
TclNewObj(objPtr);
Tcl_SetByteArrayObj(objPtr, bytes, 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.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_MEM_DEBUG
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. */
{
Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
Tcl_SetByteArrayObj(objPtr, bytes, length);
return objPtr;
}
#else /* if not TCL_MEM_DEBUG */
Tcl_Obj *
Tcl_DbNewByteArrayObj(
const unsigned char *bytes, /* The array of bytes used to initialize the
* new object. */
int length, /* Length of the array of bytes, which must be
* >= 0. */
const char *file, /* The name of the source file calling this
* procedure; used for debugging. */
int line) /* Line number in the source file; used for
* debugging. */
{
return Tcl_NewByteArrayObj(bytes, 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. */
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);
Tcl_InvalidateStringRep(objPtr);
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
byteArrayPtr->used = length;
byteArrayPtr->allocated = length;
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 = (ByteArray *) ckrealloc(
(char *) byteArrayPtr, BYTEARRAY_SIZE(length));
byteArrayPtr->allocated = length;
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(
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
int length;
char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
if (objPtr->typePtr != &tclByteArrayType) {
src = TclGetStringFromObj(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;
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((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(
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(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 = (char *) ckalloc((unsigned) (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';
}
}
/*
*----------------------------------------------------------------------
*
* Tcl_BinaryObjCmd --
*
* This procedure implements the "binary" Tcl command.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
Tcl_BinaryObjCmd(
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 */
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;
char *errorValue, *str;
int offset, size, length, index;
static const char *options[] = {
"format", "scan", NULL
};
enum options {
BINARY_FORMAT, BINARY_SCAN
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "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 = TclGetString(objv[2]);
arg = 3;
offset = 0;
length = 0;
while (*format != '\0') {
str = format;
flags = 0;
if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
break;
}
switch (cmd) {
case 'a':
case 'A':
case 'b':
case 'B':
case 'h':
case 'H':
/*
* For string-type specifiers, the count corresponds to the
* number of bytes in a single argument.
*/
if (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_AppendResult(interp,
"number of elements in list does not match count",
NULL);
return TCL_ERROR;
}
}
offset += count*size;
break;
case 'x':
if (count == BINARY_ALL) {
Tcl_AppendResult(interp,
"cannot use \"*\" in format string with \"x\"",
NULL);
return TCL_ERROR;
} else if (count == BINARY_NOCOUNT) {
count = 1;
}
offset += count;
break;
case 'X':
if (count == BINARY_NOCOUNT) {
count = 1;
}
if ((count > offset) || (count == BINARY_ALL)) {
count = offset;
}
if (offset > length) {
length = offset;
}
offset -= count;
break;
case '@':
if (offset > length) {
length = offset;
}
if (count == BINARY_ALL) {
offset = length;
} else if (count == BINARY_NOCOUNT) {
goto badCount;
} else {
offset = count;
}
break;
default:
errorString = str;
goto badField;
}
}
if (offset > length) {
length = offset;
}
if (length == 0) {
return TCL_OK;
}
/*
* Prepare the result object by preallocating the caclulated number of
* bytes and filling with nulls.
*/
resultPtr = Tcl_NewObj();
buffer = Tcl_SetByteArrayLength(resultPtr, length);
memset(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 = TclGetString(objv[2]);
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++ = (unsigned char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 1;
if (str[offset] == '1') {
value |= 128;
} else if (str[offset] != '0') {
errorValue = str;
Tcl_DecrRefCount(resultPtr);
goto badValue;
}
if (!((offset + 1) % 8)) {
*cursor++ = (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 = 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++ = (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 '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);
break;
case BINARY_SCAN: {
int i;
Tcl_Obj *valuePtr, *elementPtr;
Tcl_HashTable numberCacheHash;
Tcl_HashTable *numberCachePtr;
if (objc < 4) {
Tcl_WrongNumArgs(interp, 2, objv,
"value formatString ?varName varName ...?");
return TCL_ERROR;
}
numberCachePtr = &numberCacheHash;
Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
format = TclGetString(objv[3]);
cursor = buffer;
arg = 4;
offset = 0;
while (*format != '\0') {
str = format;
flags = 0;
if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
goto done;
}
switch (cmd) {
case 'a':
case 'A': {
unsigned char *src;
if (arg >= objc) {
DeleteScanNumberCache(numberCachePtr);
goto badIndex;
}
if (count == 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;
int i;
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 - 4));
DeleteScanNumberCache(numberCachePtr);
break;
}
}
return TCL_OK;
badValue:
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "expected ", errorString,
" string but got \"", errorValue, "\" instead", NULL);
return TCL_ERROR;
badCount:
errorString = "missing count for \"@\" field specifier";
goto error;
badIndex:
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(
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, 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 int 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)++ = (unsigned char) wvalue;
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
} else {
*(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) wvalue;
}
return TCL_OK;
/*
* 32-bit integer values.
*/
case 'i':
case 'I':
case 'n':
if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (NeedReversing(type)) {
*(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 24);
} else {
*(*cursorPtr)++ = (unsigned char) (value >> 24);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) 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)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
} else {
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
}
return TCL_OK;
/*
* 8-bit integer values.
*/
case 'c':
if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
*(*cursorPtr)++ = (unsigned char) 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 int)1)<<31)) && (value > 0)) {
value -= (((unsigned int)1)<<31);
value -= (((unsigned int)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, (char *)value, &isNew);
if (!isNew) {
return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
}
if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
Tcl_IncrRefCount(objPtr);
Tcl_SetHashValue(hPtr, (ClientData) 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);
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
|
