/*
 * 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.13.4.19 2008/05/11 04:22:36 dgp Exp $
 */

#include "tclInt.h"
#include "tommath.h"

#include <math.h>

static int		SetByteArrayFromAny(Tcl_Interp *interp,
			    Tcl_Obj *objPtr);
static void		UpdateStringOfByteArray(Tcl_Obj *listPtr);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(const void *from, void *to,
			    unsigned int length, int type);
/* Binary ensemble commands */
static int		BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);
static int		BinaryScanCmd(ClientData clientData, Tcl_Interp *interp,
			    int objc, Tcl_Obj *const objv[]);

/*
 * Default description of the "binary" ensemble
 */

static const EnsembleImplMap defaultBinaryMap[] = {
    { "format",		BinaryFormatCmd, 	NULL},
    { "scan",		BinaryScanCmd,		NULL},
    { NULL, NULL, NULL }
};

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

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

	*dst = '\0';
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclInitBinaryCmd --
 *
 *	This function is called to create the "binary" Tcl command. See the user
 *	documentation for details on what it does.
 *
 * Results:
 *	A command token for the new command.
 *
 * Side effects:
 *	Creates a new binary command as a mapped ensemble.
 *
 *----------------------------------------------------------------------
 */

Tcl_Command
TclInitBinaryCmd(Tcl_Interp *interp)
{
    return TclMakeEnsemble(interp, "binary", defaultBinaryMap);
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryFormatCmd --
 *
 *	This procedure implements the "binary format" Tcl command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
BinaryFormatCmd(
    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.

    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
    const char *errorString;
    char *errorValue, *str;
    int offset, size, length;







    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?");
	return TCL_ERROR;
    }













    /*
     * To avoid copying the data, we format the string in two passes. The
     * first pass computes the size of the output buffer. The second pass
     * places the formatted data into the buffer.
     */
    
    format = TclGetString(objv[1]);
    arg = 2;
    offset = 0;
    length = 0;
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    break;
	}
	switch (cmd) {
	    case 'a':
	    case 'A':
	    case 'b':
	    case 'B':
	    case 'h':
	    case 'H':
		/*
		 * For string-type specifiers, the count corresponds to the
		 * number of bytes in a single argument.
		 */
		
		if (arg >= objc) {
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    Tcl_GetByteArrayFromObj(objv[arg], &count);
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;

		if (count == BINARY_NOCOUNT) {
		    arg++;
		    count = 1;
		} else {
		    int listc;
		    Tcl_Obj **listv;
		    
		    /* The macro evals its args more than once: avoid arg++ */		    
		    if (TclListObjGetElements(interp, objv[arg], &listc,
			    &listv) != TCL_OK) {
			return TCL_ERROR;
		    }
		    arg++;
		    
		    if (count == BINARY_ALL) {
			count = listc;
		    } else if (count > listc) {
			Tcl_AppendResult(interp,
			    "number of elements in list does not match count",
			    NULL);
			return TCL_ERROR;
		    }
		}
		offset += count*size;
		break;
		
	    case 'x':
		if (count == BINARY_ALL) {
		    Tcl_AppendResult(interp,
			"cannot use \"*\" in format string with \"x\"",
			NULL);
		    return TCL_ERROR;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		offset += count;
		break;
	    case 'X':

		} else {
		    offset = count;
		}
		break;
	    default:
		errorString = str;
		goto badField;
	}
    }
    if (offset > length) {
	length = offset;
    }
    if (length == 0) {
	return TCL_OK;
    }
    
    /*
     * Prepare the result object by preallocating the caclulated number of
     * bytes and filling with nulls.
     */
    
    resultPtr = Tcl_NewObj();
    buffer = Tcl_SetByteArrayLength(resultPtr, length);
    memset(buffer, 0, (size_t) length);
    
    /*
     * Pack the data into the result object. Note that we can skip the
     * error checking during this pass, since we have already parsed the
     * string once.
     */

    arg = 2;
    format = TclGetString(objv[1]);
    cursor = buffer;
    maxPos = cursor;
    while (*format != 0) {
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    break;
	}
	if ((count == 0) && (cmd != '@')) {
	    if (cmd != 'x') {
		arg++;
	    }
	    continue;
	}
	switch (cmd) {
	    case 'a':
	    case 'A': {
		char pad = (char) (cmd == 'a' ? '\0' : ' ');
		unsigned char *bytes;
		
		bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
		
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}
		if (length >= count) {
		    memcpy(cursor, bytes, (size_t) count);
		} else {
		    memcpy(cursor, bytes, (size_t) length);
		    memset(cursor + length, pad, (size_t) (count - length));
		}
		cursor += count;
		break;
	    }
	    case 'b':
	    case 'B': {
		unsigned char *last;
		
		str = TclGetStringFromObj(objv[arg], &length);
		arg++;
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}

		}
		break;
	    }
	    case 'h':
	    case 'H': {
		unsigned char *last;
		int c;
		
		str = TclGetStringFromObj(objv[arg], &length);
		arg++;
		if (count == BINARY_ALL) {
		    count = length;
		} else if (count == BINARY_NOCOUNT) {
		    count = 1;
		}

		}
		if (count == BINARY_ALL) {
		    cursor = maxPos;
		} else {
		    cursor = buffer + count;
		}
		break;
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);
    Tcl_AppendResult(interp, "expected ", errorString,
	" string but got \"", errorValue, "\" instead", NULL);
    return TCL_ERROR;
    
 badCount:
    errorString = "missing count for \"@\" field specifier";
    goto error;
    
 badIndex:
    errorString = "not enough arguments for all format specifiers";
    goto error;
    
 badField:
    {
	Tcl_UniChar ch;
	char buf[TCL_UTF_MAX + 1];
	
	Tcl_UtfToUniChar(errorString, &ch);
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
	return TCL_ERROR;
    }
    
 error:
    Tcl_AppendResult(interp, errorString, NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryScanCmd --
 *
 *	This procedure implements the "binary scan" Tcl command.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
BinaryScanCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    int arg;			/* Index of next argument to consume. */
    int value = 0;		/* Current integer value to be packed.
				 * Initialized to avoid compiler warning. */
    char cmd;			/* Current format character. */
    int count;			/* Count associated with current format
				 * character. */
    int flags;			/* Format field flags */
    char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    const char *errorString;
    char *str;
    int offset, size, length;

    int i;
    Tcl_Obj *valuePtr, *elementPtr;
    Tcl_HashTable numberCacheHash;
    Tcl_HashTable *numberCachePtr;
    
    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv,
	    "value formatString ?varName varName ...?");
	return TCL_ERROR;
    }
    numberCachePtr = &numberCacheHash;
    Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
    buffer = Tcl_GetByteArrayFromObj(objv[1], &length);
    format = TclGetString(objv[2]);
    cursor = buffer;
    arg = 3;
    offset = 0;
    while (*format != '\0') {
	str = format;
	flags = 0;
	if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
	    goto done;
	}
	switch (cmd) {
	    case 'a':
	    case 'A': {
		unsigned char *src;
		
		if (arg >= objc) {
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_ALL) {
		    count = length - offset;
		} else {
		    if (count == BINARY_NOCOUNT) {
			count = 1;
		    }
		    if (count > (length - offset)) {
			goto done;
		    }
		}
		
		src = buffer + offset;
		size = count;
		
		/*
		 * Trim trailing nulls and spaces, if necessary.
		 */
		
		if (cmd == 'A') {
		    while (size > 0) {
			if (src[size-1] != '\0' && src[size-1] != ' ') {
			    break;
			}
			size--;
		    }
		}
		
		/*
		 * Have to do this #ifdef-fery because (as part of defining
		 * Tcl_NewByteArrayObj) we removed the #def that hides this
		 * stuff normally. If this code ever gets copied to another
		 * file, it should be changed back to the simpler version.
		 */

		    offset = count;
		}
		break;
	    default:
		DeleteScanNumberCache(numberCachePtr);
		errorString = str;
		goto badField;
	}
    }
    
    /*
     * Set the result to the last position of the cursor.
     */
    
 done:
    Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3));
    DeleteScanNumberCache(numberCachePtr);

    

    return TCL_OK;
    






 badCount:
    errorString = "missing count for \"@\" field specifier";
    goto error;
    
 badIndex:
    errorString = "not enough arguments for all format specifiers";
    goto error;
    
 badField:
    {
	Tcl_UniChar ch;
	char buf[TCL_UTF_MAX + 1];
	
	Tcl_UtfToUniChar(errorString, &ch);
	buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
	Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
	return TCL_ERROR;
    }
    
 error:
    Tcl_AppendResult(interp, errorString, NULL);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *