/* 

 * 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.

 * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.  

 *

 * 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.13.2.4 2005/10/23 22:01:29 msofer Exp $

 */

#include "tclInt.h"

#include "tclPort.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 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 _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		CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,

			    unsigned int length));

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, Tcl_HashTable **numberCachePtr));

static int		SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,

			    Tcl_Obj *objPtr));

static void		UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));

static void		DeleteScanNumberCache _ANSI_ARGS_((

			    Tcl_HashTable *numberCachePtr));

/*

 * 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

EXPORT_C Tcl_Obj *

Tcl_NewByteArrayObj(bytes, length)

    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 */

EXPORT_C Tcl_Obj *

Tcl_NewByteArrayObj(bytes, length)

    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

EXPORT_C Tcl_Obj *

Tcl_DbNewByteArrayObj(bytes, length, file, line)

    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 */

EXPORT_C Tcl_Obj *

Tcl_DbNewByteArrayObj(bytes, length, file, line)

    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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C void

Tcl_SetByteArrayObj(objPtr, bytes, length)

    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. */

{

    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.

 *

 *----------------------------------------------------------------------

 */

EXPORT_C 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.

 *

 *---------------------------------------------------------------------------

 */

EXPORT_C unsigned char *

Tcl_SetByteArrayLength(objPtr, length)

    Tcl_Obj *objPtr;		/* The ByteArray object. */

    int length;			/* New length for internal byte array. */

{

    ByteArray *byteArrayPtr, *newByteArrayPtr;

    if (Tcl_IsShared(objPtr)) {

	panic("Tcl_SetObjLength called with shared object");

    }

    if (objPtr->typePtr != &tclByteArrayType) {

	SetByteArrayFromAny(NULL, objPtr);

    }

    byteArrayPtr = GET_BYTEARRAY(objPtr);

    if (length > byteArrayPtr->allocated) {

	newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));

	newByteArrayPtr->used = length;

	newByteArrayPtr->allocated = length;

	memcpy((VOID *) newByteArrayPtr->bytes,

		(VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);

	ckfree((char *) byteArrayPtr);

	byteArrayPtr = newByteArrayPtr;

	SET_BYTEARRAY(objPtr, byteArrayPtr);

    }

    Tcl_InvalidateStringRep(objPtr);

    byteArrayPtr->used = length;

    return byteArrayPtr->bytes;

}

/*

 *---------------------------------------------------------------------------

 *

 * SetByteArrayFromAny --

 *

 *	Generate the ByteArray internal rep from the string rep.

 *

 * Results:

 *	The return value is always TCL_OK.

 *

 * Side effects:

 *	A ByteArray object is stored as the internal rep of objPtr.

 *

 *---------------------------------------------------------------------------

 */

static int

SetByteArrayFromAny(interp, objPtr)

    Tcl_Interp *interp;		/* Not used. */

    Tcl_Obj *objPtr;		/* The object to convert to type ByteArray. */

{

    Tcl_ObjType *typePtr;

    int length;

    char *src, *srcEnd;

    unsigned char *dst;

    ByteArray *byteArrayPtr;

    Tcl_UniChar ch;

    typePtr = objPtr->typePtr;

    if (typePtr != &tclByteArrayType) {

	src = Tcl_GetStringFromObj(objPtr, &length);

	srcEnd = src + length;

	byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));

	for (dst = byteArrayPtr->bytes; src < srcEnd; ) {

	    src += Tcl_UtfToUniChar(src, &ch);

	    *dst++ = (unsigned char) ch;

	}

	byteArrayPtr->used = dst - byteArrayPtr->bytes;

	byteArrayPtr->allocated = length;

	if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {

	    (*typePtr->freeIntRepProc)(objPtr);

	}

	objPtr->typePtr = &tclByteArrayType;

	SET_BYTEARRAY(objPtr, byteArrayPtr);

    }

    return TCL_OK;

}

/*

 *----------------------------------------------------------------------

 *

 * FreeByteArrayInternalRep --

 *

 *	Deallocate the storage associated with a ByteArray data object's

 *	internal representation.

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	Frees memory. 

 *

 *----------------------------------------------------------------------

 */

static void

FreeByteArrayInternalRep(objPtr)

    Tcl_Obj *objPtr;		/* Object with internal rep to free. */

{

    ckfree((char *) GET_BYTEARRAY(objPtr));

}

/*

 *---------------------------------------------------------------------------

 *

 * DupByteArrayInternalRep --

 *

 *	Initialize the internal representation of a ByteArray Tcl_Obj

 *	to a copy of the internal representation of an existing ByteArray

 *	object. 

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	Allocates memory.

 *

 *---------------------------------------------------------------------------

 */

static void

DupByteArrayInternalRep(srcPtr, copyPtr)

    Tcl_Obj *srcPtr;		/* Object with internal rep to copy. */

    Tcl_Obj *copyPtr;		/* Object with internal rep to set. */

{

    int length;

    ByteArray *srcArrayPtr, *copyArrayPtr;    

    srcArrayPtr = GET_BYTEARRAY(srcPtr);

    length = srcArrayPtr->used;

    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));

    copyArrayPtr->used = length;

    copyArrayPtr->allocated = length;

    memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,

	    (size_t) length);

    SET_BYTEARRAY(copyPtr, copyArrayPtr);

    copyPtr->typePtr = &tclByteArrayType;

}

/*

 *---------------------------------------------------------------------------

 *

 * UpdateStringOfByteArray --

 *

 *	Update the string representation for a ByteArray data object.

 *	Note: This procedure does not invalidate an existing old string rep

 *	so storage will be lost if this has not already been done. 

 *

 * Results:

 *	None.

 *

 * Side effects:

 *	The object's string is set to a valid string that results from

 *	the ByteArray-to-string conversion.

 *

 *	The object becomes a string object -- the internal rep is

 *	discarded and the typePtr becomes NULL.

 *

 *---------------------------------------------------------------------------

 */

static void

UpdateStringOfByteArray(objPtr)

    Tcl_Obj *objPtr;		/* ByteArray object whose string rep to

				 * update. */

{

    int i, length, size;

    unsigned char *src;

    char *dst;

    ByteArray *byteArrayPtr;

    byteArrayPtr = GET_BYTEARRAY(objPtr);

    src = byteArrayPtr->bytes;

    length = byteArrayPtr->used;

    /*

     * How much space will string rep need?

     */

    size = length;

    for (i = 0; i < length; i++) {

	if ((src[i] == 0) || (src[i] > 127)) {

	    size++;

	}

    }

    dst = (char *) ckalloc((unsigned) (size + 1));

    objPtr->bytes = dst;

    objPtr->length = size;

    if (size == length) {

	memcpy((VOID *) dst, (VOID *) src, (size_t) size);

	dst[size] = '\0';

    } else {

	for (i = 0; i < length; i++) {

	    dst += Tcl_UniCharToUtf(src[i], dst);

	}

	*dst = '\0';

    }

}

/*

 *----------------------------------------------------------------------

 *

 * Tcl_BinaryObjCmd --

 *

 *	This procedure implements the "binary" Tcl command.

 *

 * Results:

 *	A standard Tcl result.

 *

 * Side effects:

 *	See the user documentation.

 *

 *----------------------------------------------------------------------

 */

int

Tcl_BinaryObjCmd(dummy, interp, objc, objv)

    ClientData dummy;		/* Not used. */

    Tcl_Interp *interp;		/* Current interpreter. */

    int objc;			/* Number of arguments. */

    Tcl_Obj *CONST objv[];	/* Argument objects. */

{

    int arg;			/* Index of next argument to consume. */

    int value = 0;		/* Current integer value to be packed.

				 * Initialized to avoid compiler warning. */

    char cmd;			/* Current format character. */

    int count;			/* Count associated with current format

				 * character. */

    char *format;		/* Pointer to current position in format

				 * string. */

    Tcl_Obj *resultPtr;		/* Object holding result buffer. */

    unsigned char *buffer;	/* Start of result buffer. */

    unsigned char *cursor;	/* Current position within result buffer. */

    unsigned char *maxPos;	/* Greatest position within result buffer that

				 * cursor has visited.*/

    char *errorString, *errorValue, *str;

    int offset, size, length, index;

    static 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 = Tcl_GetString(objv[2]);

	    arg = 3;

	    offset = 0;

	    length = 0;

	    while (*format != '\0') {

		str = format;

		if (!GetFormatSpec(&format, &cmd, &count)) {

		    break;

		}

		switch (cmd) {

		    case 'a':

		    case 'A':

		    case 'b':

		    case 'B':

		    case 'h':

		    case 'H': {

			/*

			 * For string-type specifiers, the count corresponds

			 * to the number of bytes in a single argument.

			 */

			if (arg >= objc) {

			    goto badIndex;

			}

			if (count == BINARY_ALL) {

			    Tcl_GetByteArrayFromObj(objv[arg], &count);

			} else if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			arg++;

			if (cmd == 'a' || cmd == 'A') {

			    offset += count;

			} else if (cmd == 'b' || cmd == 'B') {

			    offset += (count + 7) / 8;

			} else {

			    offset += (count + 1) / 2;

			}

			break;

		    }

		    case 'c': {

			size = 1;

			goto doNumbers;

		    }

		    case 's':

		    case 'S': {

			size = 2;

			goto doNumbers;

		    }

		    case 'i':

		    case 'I': {

			size = 4;

			goto doNumbers;

		    }

		    case 'w':

		    case 'W': {

			size = 8;

			goto doNumbers;

		    }

		    case 'f': {

			size = sizeof(float);

			goto doNumbers;

		    }

		    case 'd': {

			size = sizeof(double);

			doNumbers:

			if (arg >= objc) {

			    goto badIndex;

			}

			/*

			 * For number-type specifiers, the count corresponds

			 * to the number of elements in the list stored in

			 * a single argument.  If no count is specified, then

			 * the argument is taken as a single non-list value.

			 */

			if (count == BINARY_NOCOUNT) {

			    arg++;

			    count = 1;

			} else {

			    int listc;

			    Tcl_Obj **listv;

			    if (Tcl_ListObjGetElements(interp, objv[arg++],

				    &listc, &listv) != TCL_OK) {

				return TCL_ERROR;

			    }

			    if (count == BINARY_ALL) {

				count = listc;

			    } else if (count > listc) {

			        Tcl_AppendResult(interp, 

					"number of elements in list does not match count",

					(char *) NULL);

				return TCL_ERROR;

			    }

			}

			offset += count*size;

			break;

		    }

		    case 'x': {

			if (count == BINARY_ALL) {

			    Tcl_AppendResult(interp, 

				    "cannot use \"*\" in format string with \"x\"",

				    (char *) NULL);

			    return TCL_ERROR;

			} else if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			offset += count;

			break;

		    }

		    case 'X': {

			if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			if ((count > offset) || (count == BINARY_ALL)) {

			    count = offset;

			}

			if (offset > length) {

			    length = offset;

			}

			offset -= count;

			break;

		    }

		    case '@': {

			if (offset > length) {

			    length = offset;

			}

			if (count == BINARY_ALL) {

			    offset = length;

			} else if (count == BINARY_NOCOUNT) {

			    goto badCount;

			} else {

			    offset = count;

			}

			break;

		    }

		    default: {

			errorString = str;

			goto badField;

		    }

		}

	    }

	    if (offset > length) {

		length = offset;

	    }

	    if (length == 0) {

		return TCL_OK;

	    }

	    /*

	     * Prepare the result object by preallocating the caclulated

	     * number of bytes and filling with nulls.

	     */

	    resultPtr = Tcl_GetObjResult(interp);

	    buffer = Tcl_SetByteArrayLength(resultPtr, length);

	    memset((VOID *) buffer, 0, (size_t) length);

	    /*

	     * Pack the data into the result object.  Note that we can skip

	     * the error checking during this pass, since we have already

	     * parsed the string once.

	     */

	    arg = 3;

	    format = Tcl_GetString(objv[2]);

	    cursor = buffer;

	    maxPos = cursor;

	    while (*format != 0) {

		if (!GetFormatSpec(&format, &cmd, &count)) {

		    break;

		}

		if ((count == 0) && (cmd != '@')) {

		    arg++;

		    continue;

		}

		switch (cmd) {

		    case 'a':

		    case 'A': {

			char pad = (char) (cmd == 'a' ? '\0' : ' ');

			unsigned char *bytes;

			bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);

			if (count == BINARY_ALL) {

			    count = length;

			} else if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			if (length >= count) {

			    memcpy((VOID *) cursor, (VOID *) bytes,

				    (size_t) count);

			} else {

			    memcpy((VOID *) cursor, (VOID *) bytes,

				    (size_t) length);

			    memset((VOID *) (cursor + length), pad,

			            (size_t) (count - length));

			}

			cursor += count;

			break;

		    }

		    case 'b':

		    case 'B': {

			unsigned char *last;

			str = Tcl_GetStringFromObj(objv[arg++], &length);

			if (count == BINARY_ALL) {

			    count = length;

			} else if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			last = cursor + ((count + 7) / 8);

			if (count > length) {

			    count = length;

			}

			value = 0;

			errorString = "binary";

			if (cmd == 'B') {

			    for (offset = 0; offset < count; offset++) {

				value <<= 1;

				if (str[offset] == '1') {

				    value |= 1;

				} else if (str[offset] != '0') {

				    errorValue = str;

				    goto badValue;

				}

				if (((offset + 1) % 8) == 0) {

				    *cursor++ = (unsigned char) value;

				    value = 0;

				}

			    }

			} else {

			    for (offset = 0; offset < count; offset++) {

				value >>= 1;

				if (str[offset] == '1') {

				    value |= 128;

				} else if (str[offset] != '0') {

				    errorValue = str;

				    goto badValue;

				}

				if (!((offset + 1) % 8)) {

				    *cursor++ = (unsigned char) value;

				    value = 0;

				}

			    }

			}

			if ((offset % 8) != 0) {

			    if (cmd == 'B') {

				value <<= 8 - (offset % 8);

			    } else {

				value >>= 8 - (offset % 8);

			    }

			    *cursor++ = (unsigned char) value;

			}

			while (cursor < last) {

			    *cursor++ = '\0';

			}

			break;

		    }

		    case 'h':

		    case 'H': {

			unsigned char *last;

			int c;

			str = Tcl_GetStringFromObj(objv[arg++], &length);

			if (count == BINARY_ALL) {

			    count = length;

			} else if (count == BINARY_NOCOUNT) {

			    count = 1;

			}

			last = cursor + ((count + 1) / 2);

			if (count > length) {

			    count = length;

			}

			value = 0;

			errorString = "hexadecimal";

			if (cmd == 'H') {

			    for (offset = 0; offset < count; offset++) {

				value <<= 4;

				if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */

				    errorValue = str;

				    goto badValue;

				}

				c = str[offset] - '0';

				if (c > 9) {

				    c += ('0' - 'A') + 10;

				}

				if (c > 16) {

				    c += ('A' - 'a');

				}

				value |= (c & 0xf);

				if (offset % 2) {

				    *cursor++ = (char) value;

				    value = 0;

				}

			    }

			} else {

			    for (offset = 0; offset < count; offset++) {

				value >>= 4;

				if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */

				    errorValue = str;

				    goto badValue;

				}

				c = str[offset] - '0';

				if (c > 9) {

				    c += ('0' - 'A') + 10;

				}

				if (c > 16) {

				    c += ('A' - 'a');

				}

				value |= ((c << 4) & 0xf0);

				if (offset % 2) {

				    *cursor++ = (unsigned char)(value & 0xff);

				    value = 0;

				}

			    }

			}

			if (offset % 2) {

			    if (cmd == 'H') {

				value <<= 4;

			    } else {

				value >>= 4;

			    }

			    *cursor++ = (unsigned char) value;

			}

			while (cursor < last) {

			    *cursor++ = '\0';

			}

			break;

		    }

		    case 'c':

		    case 's':

		    case 'S':

		    case 'i':

		    case 'I':

		    case 'w':

		    case 'W':

		    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);