/* 
 * 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 2003/02/21 21:54:11 dkf Exp $
 * RCS: @(#) $Id: tclBinary.c,v 1.14 2003/12/02 09:29:54 dkf Exp $
 */

#include "tclInt.h"
#include "tclPort.h"
#include <math.h>

/*

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

			} else {
			    offset = count;
			}
			break;
		    }
		    default: {
			errorString = str;
			goto badfield;
			goto badField;
		    }
		}
	    }
	    if (offset > length) {
		length = offset;
	    }
	    if (length == 0) {

		}
		switch (cmd) {
		    case 'a':
		    case 'A': {
			unsigned char *src;

			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = length - offset;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;

			    }
			}
			valuePtr = Tcl_NewByteArrayObj(src, size);
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += count;
			break;
		    }
		    case 'b':
		    case 'B': {
			unsigned char *src;
			char *dest;

			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset) * 8;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;

			    }
			}
			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 7 ) / 8;
			break;
		    }
		    case 'h':
		    case 'H': {
			char *dest;
			unsigned char *src;
			int i;
			static char hexdigit[] = "0123456789abcdef";

			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset)*2;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;

			    }
			}
			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 1) / 2;
			break;
		    }
		    case 'c': {

			unsigned char *src;

			size = sizeof(double);
			/* fall through */
			
			scanNumber:
			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_NOCOUNT) {
			    if ((length - offset) < size) {
				goto done;
			    }
			    valuePtr = ScanNumber(buffer+offset, cmd,

			    offset += count*size;
			}

			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			break;
		    }
		    case 'x': {
			if (count == BINARY_NOCOUNT) {

			} else {
			    offset -= count;
			}
			break;
		    }
		    case '@': {
			if (count == BINARY_NOCOUNT) {
			    if (numberCachePtr != NULL) {
			    DeleteScanNumberCache(numberCachePtr);
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badCount;
			}
			if ((count == BINARY_ALL) || (count > length)) {
			    offset = length;
			} else {
			    offset = count;
			}
			break;
		    }
		    default: {
			if (numberCachePtr != NULL) {
			DeleteScanNumberCache(numberCachePtr);
			    Tcl_DeleteHashTable(numberCachePtr);
			}
			errorString = str;
			goto badfield;
			goto badField;
		    }
		}
	    }

	    /*
	     * Set the result to the last position of the cursor.
	     */

	    done:
	    Tcl_ResetResult(interp);
	    Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
	    if (numberCachePtr != NULL) {
	    DeleteScanNumberCache(numberCachePtr);
		Tcl_DeleteHashTable(numberCachePtr);
	    }
	    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;

    badfield: {
    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;

		     * a LOT of varied binary data in a single call!
		     * Bail out by switching back to the old behaviour
		     * for the rest of the scan.
		     *
		     * Note that anyone just using the 'c' conversion
		     * (for bytes) cannot trigger this.
		     */
		    Tcl_DeleteHashTable(tablePtr);
		    DeleteScanNumberCache(tablePtr);
		    *numberCachePtrPtr = NULL;
		    return Tcl_NewLongObj(value);
		} else {
		    register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
		    /* Don't need to fiddle with refcount... */

		    Tcl_IncrRefCount(objPtr);
		    Tcl_SetHashValue(hPtr, (ClientData) objPtr);
		    return objPtr;
		}
	    }

	    /*
	     * Do not cache wide values; they are already too large to
	     * use as keys.
	     */
	case 'w':
	    uwvalue =  ((Tcl_WideUInt) buffer[0])
		    | (((Tcl_WideUInt) buffer[1]) << 8)
		    | (((Tcl_WideUInt) buffer[2]) << 16)
		    | (((Tcl_WideUInt) buffer[3]) << 24)
		    | (((Tcl_WideUInt) buffer[4]) << 32)
		    | (((Tcl_WideUInt) buffer[5]) << 40)
		    | (((Tcl_WideUInt) buffer[6]) << 48)
		    | (((Tcl_WideUInt) buffer[7]) << 56);
	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
	case 'W':
	    uwvalue =  ((Tcl_WideUInt) buffer[7])
		    | (((Tcl_WideUInt) buffer[6]) << 8)
		    | (((Tcl_WideUInt) buffer[5]) << 16)
		    | (((Tcl_WideUInt) buffer[4]) << 24)
		    | (((Tcl_WideUInt) buffer[3]) << 32)
		    | (((Tcl_WideUInt) buffer[2]) << 40)
		    | (((Tcl_WideUInt) buffer[1]) << 48)
		    | (((Tcl_WideUInt) buffer[0]) << 56);
	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);

	    /*
	     * Do not cache double values; they are already too large
	     * to use as keys and the values stored are utterly
	     * incompatible too.
	     */
	case 'f': {
	    float fvalue;
	    memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
	    return Tcl_NewDoubleObj(fvalue);
	}
	case 'd': {
	    double dvalue;
	    memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
	    return Tcl_NewDoubleObj(dvalue);
	}
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * DeleteScanNumberCache --
 * 
 *	Deletes the hash table acting as a scan number cache.
 *
 * Results:
 *	None
 *
 * Side effects:
 *	Decrements the reference counts of the objects in the cache.
 *
 *----------------------------------------------------------------------
 */

static void
DeleteScanNumberCache(numberCachePtr)
    Tcl_HashTable *numberCachePtr;	/* Pointer to the hash table, or
					 * NULL (when the cache has already
					 * been deleted due to overflow.) */
{
    Tcl_HashEntry *hEntry;
    Tcl_HashSearch search;

    if (numberCachePtr == NULL) {
	return;
    }

    hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
    while (hEntry != NULL) {
	register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);

	Tcl_DecrRefCount(value);
	hEntry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(numberCachePtr);
}