/*
* 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.4 1999/03/10 05:52:46 stanton Exp $
*/
#include <math.h>
#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. This type should
* be used to represent arbitrary binary data instead of a string object
* because although they are equivalent at the moment they will not be in
* future versions which support unicode.
*/
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 normally called when not debugging: i.e., when
* TCL_MEM_DEBUG is not defined. It creates a new ByteArray object and
* initializes it from the given array of bytes.
*
* When TCL_MEM_DEBUG is defined, this procedure just returns the
* result of calling the debugging version Tcl_DbNewByteArrayObj.
*
* 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;
ByteArray *byteArrayPtr;
typePtr = objPtr->typePtr;
if (typePtr != &tclByteArrayType) {
src = Tcl_GetStringFromObj(objPtr, &length);
byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
memcpy((VOID *) byteArrayPtr->bytes, (VOID *) src, (size_t) length);
byteArrayPtr->used = length;
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);
}
/*
*---------------------------------------------------------------------------
*
* 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 length;
unsigned char *src;
char *dst;
ByteArray *byteArrayPtr;
byteArrayPtr = GET_BYTEARRAY(objPtr);
src = byteArrayPtr->bytes;
length = byteArrayPtr->used;
/*
* The byte array is the string representation.
*/
dst = (char *) ckalloc((unsigned) (length + 1));
objPtr->bytes = dst;
objPtr->length = length;
memcpy((VOID *) dst, (VOID *) src, (size_t) length);
dst[length] = '\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;
static char *subCmds[] = { "format", "scan", (char *) NULL };
enum { BinaryFormat, BinaryScan } index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
(int *) &index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case BinaryFormat:
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_GetStringFromObj(objv[2], NULL);
arg = 3;
offset = length = 0;
while (*format != 0) {
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 characters 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) {
errorString = "number of elements in list does not match count";
goto error;
}
}
offset += count*size;
break;
case 'x':
if (count == BINARY_ALL) {
errorString = "cannot use \"*\" in format string with \"x\"";
goto 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: {
char buf[2];
Tcl_ResetResult(interp);
buf[0] = cmd;
buf[1] = '\0';
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad field specifier \"", buf, "\"", NULL);
return TCL_ERROR;
}
}
}
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(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_GetStringFromObj(objv[2], NULL);
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(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++ = (char)(value & 0xff);
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++ = (char)(value & 0xff);
value = 0;
}
}
}
if ((offset % 8) != 0) {
if (cmd == 'B') {
value <<= 8 - (offset % 8);
} else {
value >>= 8 - (offset % 8);
}
*cursor++ = (char)(value & 0xff);
}
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;
c = tolower(((unsigned char *) str)[offset]);
if ((c >= 'a') && (c <= 'f')) {
value |= ((c - 'a' + 10) & 0xf);
} else if ((c >= '0') && (c <= '9')) {
value |= (c - '0') & 0xf;
} else {
errorValue = str;
goto badValue;
}
if (offset % 2) {
*cursor++ = (char) value;
value = 0;
}
}
} else {
for (offset = 0; offset < count; offset++) {
value >>= 4;
c = tolower(((unsigned char *) str)[offset]);
if ((c >= 'a') && (c <= 'f')) {
value |= ((c - 'a' + 10) << 4) & 0xf0;
} else if ((c >= '0') && (c <= '9')) {
value |= ((c - '0') << 4) & 0xf0;
} else {
errorValue = str;
goto badValue;
}
if (offset % 2) {
*cursor++ = (char)(value & 0xff);
value = 0;
}
}
}
if (offset % 2) {
if (cmd == 'H') {
value <<= 4;
} else {
value >>= 4;
}
*cursor++ = (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 BinaryScan: {
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_GetStringFromObj(objv[3], NULL);
cursor = buffer;
arg = 4;
offset = 0;
while (*format != 0) {
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 | TCL_PARSE_PART1);
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_GetStringFromObj(valuePtr, NULL);
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 | TCL_PARSE_PART1);
if (resultPtr == NULL) {
Tcl_DecrRefCount(valuePtr); /* unneeded */
return TCL_ERROR;
}
offset += (count + 7 ) / 8;
break;
}
case 'h':
case 'H': {
unsigned char *src;
char *dest;
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_GetStringFromObj(valuePtr, NULL);
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 | TCL_PARSE_PART1);
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 | TCL_PARSE_PART1);
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: {
char buf[2];
Tcl_ResetResult(interp);
buf[0] = cmd;
buf[1] = '\0';
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad field specifier \"", buf, "\"", NULL);
return TCL_ERROR;
}
}
}
/*
* 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;
error:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
return TCL_ERROR;
}
/*
*----------------------------------------------------------------------
*
* GetFormatSpec --
*
* This function parses the format strings used in the binary
* format and scan commands.
*
* Results:
* Moves the formatPtr to the start of the next command. Returns
* the current command character and count in cmdPtr and countPtr.
* The count is set to BINARY_ALL if the count character was '*'
* or BINARY_NOCOUNT if no count was specified. Returns 1 on
* success, or 0 if the string did not have a format specifier.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
GetFormatSpec(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))) {
(*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;
char cmd = (char)type;
if (cmd == 'd' || cmd == '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 (cmd == 'd') {
memcpy((*cursorPtr), &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((*cursorPtr), &fvalue, sizeof(float));
(*cursorPtr) += sizeof(float);
}
} else {
if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
return TCL_ERROR;
}
if (cmd == 'c') {
*(*cursorPtr)++ = (char)(value & 0xff);
} else if (cmd == 's') {
*(*cursorPtr)++ = (char)(value & 0xff);
*(*cursorPtr)++ = (char)((value >> 8) & 0xff);
} else if (cmd == 'S') {
*(*cursorPtr)++ = (char)((value >> 8) & 0xff);
*(*cursorPtr)++ = (char)(value & 0xff);
} else if (cmd == 'i') {
*(*cursorPtr)++ = (char)(value & 0xff);
*(*cursorPtr)++ = (char)((value >> 8) & 0xff);
*(*cursorPtr)++ = (char)((value >> 16) & 0xff);
*(*cursorPtr)++ = (char)((value >> 24) & 0xff);
} else if (cmd == 'I') {
*(*cursorPtr)++ = (char)((value >> 24) & 0xff);
*(*cursorPtr)++ = (char)((value >> 16) & 0xff);
*(*cursorPtr)++ = (char)((value >> 8) & 0xff);
*(*cursorPtr)++ = (char)(value & 0xff);
}
}
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" */
{
int 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 ((char) type) {
case 'c':
value = buffer[0];
if (value & 0x80) {
value |= -0x100;
}
return Tcl_NewLongObj((long)value);
case 's':
value = (((unsigned char)buffer[0])
+ ((unsigned char)buffer[1] << 8));
goto shortValue;
case 'S':
value = (((unsigned char)buffer[1])
+ ((unsigned char)buffer[0] << 8));
shortValue:
if (value & 0x8000) {
value |= -0x10000;
}
return Tcl_NewLongObj((long)value);
case 'i':
value = (((unsigned char)buffer[0])
+ ((unsigned char)buffer[1] << 8)
+ ((unsigned char)buffer[2] << 16)
+ ((unsigned char)buffer[3] << 24));
goto intValue;
case 'I':
value = (((unsigned char)buffer[3])
+ ((unsigned char)buffer[2] << 8)
+ ((unsigned char)buffer[1] << 16)
+ ((unsigned char)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((long)value);
case 'f': {
float fvalue;
memcpy(&fvalue, buffer, sizeof(float));
return Tcl_NewDoubleObj(fvalue);
}
case 'd': {
double dvalue;
memcpy(&dvalue, buffer, sizeof(double));
return Tcl_NewDoubleObj(dvalue);
}
}
return NULL;
}