path: root/generic/tclBinary.c

/* 
 * 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.3.4.1 1999/03/03 00:38:39 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;
}