Logo Search packages:      
Sourcecode: tcl8.6 version File versions

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.47 2008/10/07 22:58:38 dkf Exp $
 */

#include "tclInt.h"
#include "tommath.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 flags may be ORed together and returned by GetFormatSpec
 */

#define BINARY_SIGNED 0       /* Field to be read as signed data */
#define BINARY_UNSIGNED 1     /* Field to be read as unsigned data */

/*
 * 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(Tcl_Obj *srcPtr,
                      Tcl_Obj *copyPtr);
static int        FormatNumber(Tcl_Interp *interp, int type,
                      Tcl_Obj *src, unsigned char **cursorPtr);
static void       FreeByteArrayInternalRep(Tcl_Obj *objPtr);
static int        GetFormatSpec(char **formatPtr, char *cmdPtr,
                      int *countPtr, int *flagsPtr);
static Tcl_Obj *  ScanNumber(unsigned char *buffer, int type,
                      int flags, Tcl_HashTable **numberCachePtr);
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[]);
/* Binary encoding sub-ensemble commands */
static int        BinaryEncodeHex(ClientData clientData, Tcl_Interp *interp,
                      int objc, Tcl_Obj *const objv[]);
static int        BinaryDecodeHex(ClientData clientData, Tcl_Interp *interp,
                      int objc, Tcl_Obj *const objv[]);
static int        BinaryEncode64(ClientData clientData, Tcl_Interp *interp,
                      int objc, Tcl_Obj *const objv[]);
static int        BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp,
                      int objc, Tcl_Obj *const objv[]);
static int        BinaryDecode64(ClientData clientData, Tcl_Interp *interp,
                      int objc, Tcl_Obj *const objv[]);

/*
 * The following tables are used by the binary encoders
 */

static const char HexDigits[16] = {
    '0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9', 'a', 'b', 'c', 'd', 'e', 'f'
};

static const char UueDigits[65] = {
    '`', '!', '"', '#', '$', '%', '&', '\'',
    '(', ')', '*', '+', ',', '-', '.', '/',
    '0', '1', '2', '3', '4', '5', '6', '7',
    '8', '9', ':', ';', '<', '=', '>', '?',
    '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
    'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
    'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
    'X', 'Y', 'Z', '[', '\\',']', '^', '_',
    '`'
};

static const char B64Digits[65] = {
    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H',
    'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P',
    'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X',
    'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f',
    'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n',
    'o', 'p', 'q', 'r', 's', 't', 'u', 'v',
    'w', 'x', 'y', 'z', '0', '1', '2', '3',
    '4', '5', '6', '7', '8', '9', '+', '/',
    '='
};

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

Tcl_Obj *
Tcl_NewByteArrayObj(
    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 */

Tcl_Obj *
Tcl_NewByteArrayObj(
    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

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    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 */

Tcl_Obj *
Tcl_DbNewByteArrayObj(
    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.
 *
 *----------------------------------------------------------------------
 */

void
Tcl_SetByteArrayObj(
    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. */
{
    ByteArray *byteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
      Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
    }
    TclFreeIntRep(objPtr);
    Tcl_InvalidateStringRep(objPtr);

    byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
    byteArrayPtr->used = length;
    byteArrayPtr->allocated = length;
    memcpy(byteArrayPtr->bytes, 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(
    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;

    if (objPtr->typePtr != &tclByteArrayType) {
      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(
    Tcl_Obj *objPtr,          /* The ByteArray object. */
    int length)               /* New length for internal byte array. */
{
    ByteArray *byteArrayPtr;

    if (Tcl_IsShared(objPtr)) {
      Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
    }
    if (objPtr->typePtr != &tclByteArrayType) {
      SetByteArrayFromAny(NULL, objPtr);
    }

    byteArrayPtr = GET_BYTEARRAY(objPtr);
    if (length > byteArrayPtr->allocated) {
      byteArrayPtr = (ByteArray *) ckrealloc(
            (char *) byteArrayPtr, BYTEARRAY_SIZE(length));
      byteArrayPtr->allocated = length;
      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(
    Tcl_Interp *interp,       /* Not used. */
    Tcl_Obj *objPtr)          /* The object to convert to type ByteArray. */
{
    int length;
    char *src, *srcEnd;
    unsigned char *dst;
    ByteArray *byteArrayPtr;
    Tcl_UniChar ch;

    if (objPtr->typePtr != &tclByteArrayType) {
      src = TclGetStringFromObj(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;

      TclFreeIntRep(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(
    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(
    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(copyArrayPtr->bytes, 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(
    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(dst, src, (size_t) size);
      dst[size] = '\0';
    } else {
      for (i = 0; i < length; i++) {
          dst += Tcl_UniCharToUtf(src[i], dst);
      }
      *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)
{
    Tcl_Namespace *nsTclPtr, *nsBinPtr, *nsEncPtr, *nsDecPtr;
    Tcl_Command binEnsemble, encEnsemble, decEnsemble;
    Tcl_Obj *binDict, *encDict, *decDict;

    /*
     * FIX ME: I so ugly - please make me pretty ... 
     */

    nsTclPtr = Tcl_FindNamespace(interp, "::tcl",
      NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsTclPtr == NULL) {
      Tcl_Panic("unable to find or create ::tcl namespace!");
    }
    nsBinPtr = Tcl_FindNamespace(interp, "::tcl::binary",
      NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsBinPtr == NULL) {
      Tcl_Panic("unable to find or create ::tcl::binary namespace!");
    }
    binEnsemble = Tcl_CreateEnsemble(interp, "::binary",
      nsBinPtr, TCL_ENSEMBLE_PREFIX);

    nsEncPtr = Tcl_FindNamespace(interp, "::tcl::binary::encode",
      NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsEncPtr == NULL) {
      Tcl_Panic("unable to find or create ::tcl::binary::encode namespace!");
    }
    encEnsemble = Tcl_CreateEnsemble(interp, "encode", 
      nsBinPtr, 0);
    
    nsDecPtr = Tcl_FindNamespace(interp, "::tcl::binary::decode",
      NULL, TCL_CREATE_NS_IF_UNKNOWN);
    if (nsDecPtr == NULL) {
      Tcl_Panic("unable to find or create ::tcl::binary::decode namespace!");
    }
    decEnsemble = Tcl_CreateEnsemble(interp, "decode",
      nsBinPtr, 0);

    TclNewObj(binDict);
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("format",-1),
      Tcl_NewStringObj("::tcl::binary::format",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("scan",-1),
      Tcl_NewStringObj("::tcl::binary::scan",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("encode",-1),
      Tcl_NewStringObj("::tcl::binary::encode",-1));
    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("decode",-1),
      Tcl_NewStringObj("::tcl::binary::decode",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::format",
      BinaryFormatCmd, NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::scan",
      BinaryScanCmd, NULL, NULL);
    Tcl_SetEnsembleMappingDict(interp, binEnsemble, binDict);
    
    TclNewObj(encDict);
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("hex",-1),
      Tcl_NewStringObj("::tcl::binary::encode::hex",-1));
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("uuencode",-1),
      Tcl_NewStringObj("::tcl::binary::encode::uuencode",-1));
    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("base64",-1),
      Tcl_NewStringObj("::tcl::binary::encode::base64",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::hex",
      BinaryEncodeHex, (ClientData)HexDigits, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::uuencode",
      BinaryEncode64, (ClientData)UueDigits, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::base64",
      BinaryEncode64, (ClientData)B64Digits, NULL);
    Tcl_SetEnsembleMappingDict(interp, encEnsemble, encDict);

    TclNewObj(decDict);
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("hex",-1),
      Tcl_NewStringObj("::tcl::binary::decode::hex",-1));
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("uuencode",-1),
      Tcl_NewStringObj("::tcl::binary::decode::uuencode",-1));
    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("base64",-1),
      Tcl_NewStringObj("::tcl::binary::decode::base64",-1));
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::hex",
      BinaryDecodeHex, (ClientData)NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::uuencode",
      BinaryDecodeUu, (ClientData)NULL, NULL);
    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::base64",
      BinaryDecode64, (ClientData)NULL, NULL);
    Tcl_SetEnsembleMappingDict(interp, decEnsemble, decDict);

    return binEnsemble;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
                         * 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. */
    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 ...?");
      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;
            }
            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 't':
          case 's':
          case 'S':
            size = 2;
            goto doNumbers;
          case 'n':
          case 'i':
          case 'I':
            size = 4;
            goto doNumbers;
          case 'm':
          case 'w':
          case 'W':
            size = 8;
            goto doNumbers;
          case 'r':
          case 'R':
          case 'f':
            size = sizeof(float);
            goto doNumbers;
          case 'q':
          case 'Q':
          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;
                
                /* 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':
            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_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;
            }
            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;
                      Tcl_DecrRefCount(resultPtr);
                      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;
                      Tcl_DecrRefCount(resultPtr);
                      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 = TclGetStringFromObj(objv[arg], &length);
            arg++;
            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;
                      Tcl_DecrRefCount(resultPtr);
                      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;
                      Tcl_DecrRefCount(resultPtr);
                      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 't':
          case 's':
          case 'S':
          case 'n':
          case 'i':
          case 'I':
          case 'm':
          case 'w':
          case 'W':
          case 'r':
          case 'R':
          case 'd':
          case 'q':
          case 'Q':
          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 {
                TclListObjGetElements(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) {
                  Tcl_DecrRefCount(resultPtr);
                  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;
      }
    }
    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 ...?");
      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.
             */

#ifdef TCL_MEM_DEBUG
            valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
#else
            valuePtr = Tcl_NewByteArrayObj(src, size);
#endif /* TCL_MEM_DEBUG */

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

            if (arg >= objc) {
                DeleteScanNumberCache(numberCachePtr);
                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 = TclGetString(valuePtr);

            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);
            arg++;
            if (resultPtr == NULL) {
                DeleteScanNumberCache(numberCachePtr);
                return TCL_ERROR;
            }
            offset += (count + 7) / 8;
            break;
          }
          case 'h':
          case 'H': {
            char *dest;
            unsigned char *src;
            int i;
            static const char hexdigit[] = "0123456789abcdef";

            if (arg >= objc) {
                DeleteScanNumberCache(numberCachePtr);
                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 = TclGetString(valuePtr);

            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);
            arg++;
            if (resultPtr == NULL) {
                DeleteScanNumberCache(numberCachePtr);
                return TCL_ERROR;
            }
            offset += (count + 1) / 2;
            break;
          }
          case 'c':
            size = 1;
            goto scanNumber;
          case 't':
          case 's':
          case 'S':
            size = 2;
            goto scanNumber;
          case 'n':
          case 'i':
          case 'I':
            size = 4;
            goto scanNumber;
          case 'm':
          case 'w':
          case 'W':
            size = 8;
            goto scanNumber;
          case 'r':
          case 'R':
          case 'f':
            size = sizeof(float);
            goto scanNumber;
          case 'q':
          case 'Q':
          case 'd': {
            unsigned char *src;

            size = sizeof(double);
            /* fall through */

          scanNumber:
            if (arg >= objc) {
                DeleteScanNumberCache(numberCachePtr);
                goto badIndex;
            }
            if (count == BINARY_NOCOUNT) {
                if ((length - offset) < size) {
                  goto done;
                }
                valuePtr = ScanNumber(buffer+offset, cmd, flags,
                      &numberCachePtr);
                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, flags,
                        &numberCachePtr);
                  src += size;
                  Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
                }
                offset += count*size;
            }

            resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
                  TCL_LEAVE_ERR_MSG);
            arg++;
            if (resultPtr == NULL) {
                DeleteScanNumberCache(numberCachePtr);
                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) {
                DeleteScanNumberCache(numberCachePtr);
                goto badCount;
            }
            if ((count == BINARY_ALL) || (count > length)) {
                offset = length;
            } else {
                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;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    char **formatPtr,         /* Pointer to format string. */
    char *cmdPtr,       /* Pointer to location of command char. */
    int *countPtr,            /* Pointer to repeat count value. */
    int *flagsPtr)            /* Pointer to field flags */
{
    /*
     * 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 == 'u') {
      (*formatPtr)++;
      (*flagsPtr) |= BINARY_UNSIGNED;
    }
    if (**formatPtr == '*') {
      (*formatPtr)++;
      (*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
      (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
      (*countPtr) = BINARY_NOCOUNT;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * NeedReversing --
 *
 *    This routine determines, if bytes of a number need to be re-ordered,
 *    and returns a numeric code indicating the re-ordering to be done.
 *    This depends on the endiannes of the machine and the desired format.
 *    It is in effect a table (whose contents depend on the endianness of
 *    the system) describing whether a value needs reversing or not. Anyone
 *    porting the code to a big-endian platform should take care to make
 *    sure that they define WORDS_BIGENDIAN though this is already done by
 *    configure for the Unix build; little-endian platforms (including
 *    Windows) don't need to do anything.
 *
 * Results:
 *    0     No re-ordering needed.
 *    1     Reverse the bytes:      01234567 <-> 76543210 (little to big)
 *    2     Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little)
 *    3     Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big)
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

static int
NeedReversing(
    int format)
{
    switch (format) {
      /* native floats and doubles: never reverse */
    case 'd':
    case 'f':
      /* big endian ints: never reverse */
    case 'I':
    case 'S':
    case 'W':
#ifdef WORDS_BIGENDIAN
      /* native ints: reverse if we're little-endian */
    case 'n':
    case 't':
    case 'm':
      /* f: reverse if we're little-endian */
    case 'Q':
    case 'R':
#else /* !WORDS_BIGENDIAN */
      /* small endian floats: reverse if we're big-endian */
    case 'r':
#endif /* WORDS_BIGENDIAN */
      return 0;

#ifdef WORDS_BIGENDIAN
      /* small endian floats: reverse if we're big-endian */
    case 'q':
    case 'r':
#else /* !WORDS_BIGENDIAN */
      /* native ints: reverse if we're little-endian */
    case 'n':
    case 't':
    case 'm':
      /* f: reverse if we're little-endian */
    case 'R':
#endif /* WORDS_BIGENDIAN */
      /* small endian ints: always reverse */
    case 'i':
    case 's':
    case 'w':
      return 1;

#ifndef WORDS_BIGENDIAN
    /*
     * The Q and q formats need special handling to account for the unusual
     * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
     * little-endian, but also reverse word order.
     */

    case 'Q':
      if (TclNokia770Doubles()) {
          return 3;
      }
      return 1;
    case 'q':
      if (TclNokia770Doubles()) {
          return 2;
      }
      return 0;
#endif
    }

    Tcl_Panic("unexpected fallthrough");
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * CopyNumber --
 *
 *    This routine is called by FormatNumber and ScanNumber to copy a
 *    floating-point number. If required, bytes are reversed while copying.
 *    The behaviour is only fully defined when used with IEEE float and
 *    double values (guaranteed to be 4 and 8 bytes long, respectively.)
 *
 * Results:
 *    None
 *
 * Side effects:
 *    Copies length bytes
 *
 *----------------------------------------------------------------------
 */

static void
CopyNumber(
    const void *from,         /* source */
    void *to,                 /* destination */
    unsigned int length,      /* Number of bytes to copy */
    int type)                 /* What type of thing are we copying? */
{
    switch (NeedReversing(type)) {
    case 0: 
      memcpy(to, from, length);
      break;
    case 1: {
      const unsigned char *fromPtr = from;
      unsigned char *toPtr = to;

      switch (length) {
      case 4:
          toPtr[0] = fromPtr[3];
          toPtr[1] = fromPtr[2];
          toPtr[2] = fromPtr[1];
          toPtr[3] = fromPtr[0];
          break;
      case 8:
          toPtr[0] = fromPtr[7];
          toPtr[1] = fromPtr[6];
          toPtr[2] = fromPtr[5];
          toPtr[3] = fromPtr[4];
          toPtr[4] = fromPtr[3];
          toPtr[5] = fromPtr[2];
          toPtr[6] = fromPtr[1];
          toPtr[7] = fromPtr[0];
          break;
      }
      break;
    }
    case 2: {
      const unsigned char *fromPtr = from;
      unsigned char *toPtr = to;

      toPtr[0] = fromPtr[4];
      toPtr[1] = fromPtr[5];
      toPtr[2] = fromPtr[6];
      toPtr[3] = fromPtr[7];
      toPtr[4] = fromPtr[0];
      toPtr[5] = fromPtr[1];
      toPtr[6] = fromPtr[2];
      toPtr[7] = fromPtr[3];
      break;
    }
    case 3: {
      const unsigned char *fromPtr = from;
      unsigned char *toPtr = to;

      toPtr[0] = fromPtr[3];
      toPtr[1] = fromPtr[2];
      toPtr[2] = fromPtr[1];
      toPtr[3] = fromPtr[0];
      toPtr[4] = fromPtr[7];
      toPtr[5] = fromPtr[6];
      toPtr[6] = fromPtr[5];
      toPtr[7] = fromPtr[4];
      break;
    }
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;
    float fvalue;

    switch (type) {
    case 'd':
    case 'q':
    case 'Q':
      /*
       * Double-precision floating point values. Tcl_GetDoubleFromObj
       * returns TCL_ERROR for NaN, but we can check by comparing the
       * object's type pointer.
       */

      if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
          if (src->typePtr != &tclDoubleType) {
            return TCL_ERROR;
          }
          dvalue = src->internalRep.doubleValue;
      }
      CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
      *cursorPtr += sizeof(double);
      return TCL_OK;

    case 'f':
    case 'r':
    case 'R':
      /*
       * Single-precision floating point values. Tcl_GetDoubleFromObj
       * returns TCL_ERROR for NaN, but we can check by comparing the
       * object's type pointer.
       */

      if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
          if (src->typePtr != &tclDoubleType) {
            return TCL_ERROR;
          }
          dvalue = src->internalRep.doubleValue;
      }

      /*
       * 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;
      }
      CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
      *cursorPtr += sizeof(float);
      return TCL_OK;

      /*
       * 64-bit integer values.
       */
    case 'w':
    case 'W':
    case 'm':
      if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
          return TCL_ERROR;
      }
      if (NeedReversing(type)) {
          *(*cursorPtr)++ = (unsigned char) wvalue;
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
      } else {
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
          *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
          *(*cursorPtr)++ = (unsigned char) wvalue;
      }
      return TCL_OK;

      /*
       * 32-bit integer values.
       */
    case 'i':
    case 'I':
    case 'n':
      if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
          return TCL_ERROR;
      }
      if (NeedReversing(type)) {
          *(*cursorPtr)++ = (unsigned char) value;
          *(*cursorPtr)++ = (unsigned char) (value >> 8);
          *(*cursorPtr)++ = (unsigned char) (value >> 16);
          *(*cursorPtr)++ = (unsigned char) (value >> 24);
      } else {
          *(*cursorPtr)++ = (unsigned char) (value >> 24);
          *(*cursorPtr)++ = (unsigned char) (value >> 16);
          *(*cursorPtr)++ = (unsigned char) (value >> 8);
          *(*cursorPtr)++ = (unsigned char) value;
      }
      return TCL_OK;

      /*
       * 16-bit integer values.
       */
    case 's':
    case 'S':
    case 't':
      if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
          return TCL_ERROR;
      }
      if (NeedReversing(type)) {
          *(*cursorPtr)++ = (unsigned char) value;
          *(*cursorPtr)++ = (unsigned char) (value >> 8);
      } else {
          *(*cursorPtr)++ = (unsigned char) (value >> 8);
          *(*cursorPtr)++ = (unsigned char) value;
      }
      return TCL_OK;

      /*
       * 8-bit integer values.
       */
    case 'c':
      if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
          return TCL_ERROR;
      }
      *(*cursorPtr)++ = (unsigned char) value;
      return TCL_OK;

    default:
      Tcl_Panic("unexpected fallthrough");
      return TCL_ERROR;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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:
 *    Might reuse an object in the number cache, place a new object in the
 *    cache, or delete the cache and set the reference to it (itself passed
 *    in by reference) to NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ScanNumber(
    unsigned char *buffer,    /* Buffer to scan number from. */
    int type,                 /* Format character from "binary scan" */
    int flags,                /* Format field flags */
    Tcl_HashTable **numberCachePtrPtr)
                        /* Place to look for cache of scanned
                         * value objects, or NULL if too many
                         * different numbers have been scanned. */
{
    long value;
    float fvalue;
    double dvalue;
    Tcl_WideUInt uwvalue;

    /*
     * 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. This practice is disabled if the BINARY_UNSIGNED flag is set.
     */

    switch (type) {
    case 'c':
      /*
       * Characters need special handling. We want to produce a signed
       * result, but on some platforms (such as AIX) chars are unsigned. To
       * deal with this, check for a value that should be negative but
       * isn't.
       */

      value = buffer[0];
      if (!(flags & BINARY_UNSIGNED)) {
          if (value & 0x80) {
            value |= -0x100;
          }
      }
      goto returnNumericObject;

      /*
       * 16-bit numeric values. We need the sign extension trick (see above)
       * here as well.
       */

    case 's':
    case 'S':
    case 't':
      if (NeedReversing(type)) {
          value = (long) (buffer[0] + (buffer[1] << 8));
      } else {
          value = (long) (buffer[1] + (buffer[0] << 8));
      }
      if (!(flags & BINARY_UNSIGNED)) {
          if (value & 0x8000) {
            value |= -0x10000;
          }
      }
      goto returnNumericObject;

      /*
       * 32-bit numeric values.
       */

    case 'i':
    case 'I':
    case 'n':
      if (NeedReversing(type)) {
          value = (long) (buffer[0]
                + (buffer[1] << 8)
                + (buffer[2] << 16)
                + (((long)buffer[3]) << 24));
      } else {
          value = (long) (buffer[3]
                + (buffer[2] << 8)
                + (buffer[1] << 16)
                + (((long)buffer[0]) << 24));
      }

      /*
       * Check to see if the value was sign extended properly on systems
       * where an int is more than 32-bits.
       * We avoid caching unsigned integers as we cannot distinguish between
       * 32bit signed and unsigned in the hash (short and char are ok).
       */

      if (flags & BINARY_UNSIGNED) {
          return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
      }
      if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
          value -= (((unsigned int)1)<<31);
          value -= (((unsigned int)1)<<31);
      }

    returnNumericObject:
      if (*numberCachePtrPtr == NULL) {
          return Tcl_NewLongObj(value);
      } else {
          register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
          register Tcl_HashEntry *hPtr;
          int isNew;

          hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
          if (!isNew) {
            return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
          }
          if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
            register Tcl_Obj *objPtr = Tcl_NewLongObj(value);

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

          /*
           * We've overflowed the cache! Someone's parsing 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.
           */

          DeleteScanNumberCache(tablePtr);
          *numberCachePtrPtr = NULL;
          return Tcl_NewLongObj(value);
      }

      /*
       * Do not cache wide (64-bit) values; they are already too large to
       * use as keys.
       */

    case 'w':
    case 'W':
    case 'm':
      if (NeedReversing(type)) {
          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);
      } else {
          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);
      }
      if (flags & BINARY_UNSIGNED) {
          Tcl_Obj *bigObj = NULL;
          mp_int big;

          TclBNInitBignumFromWideUInt(&big, uwvalue);
          bigObj = Tcl_NewBignumObj(&big);
          return bigObj;
      }
      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 with the
       * integer part of the cache.
       */

      /*
       * 32-bit IEEE single-precision floating point.
       */

    case 'f':
    case 'R':
    case 'r':
      CopyNumber(buffer, &fvalue, sizeof(float), type);
      return Tcl_NewDoubleObj(fvalue);

      /*
       * 64-bit IEEE double-precision floating point.
       */

    case 'd':
    case 'Q':
    case 'q':
      CopyNumber(buffer, &dvalue, sizeof(double), type);
      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(
    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_GetHashValue(hEntry);

      if (value != NULL) {
          Tcl_DecrRefCount(value);
      }
      hEntry = Tcl_NextHashEntry(&search);
    }
    Tcl_DeleteHashTable(numberCachePtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * NOTES --
 *
 *    Some measurements show that it is faster to use a table to to perform
 *    uuencode and base64 value encoding than to calculate the output (at
 *    least on intel P4 arch).
 *
 *    Conversely using a lookup table for the decoding is slower than just
 *    calculating the values. We therefore use the fastest of each method.
 *
 *    Presumably this has to do with the size of the tables. The base64
 *    decode table is 255 bytes while the encode table is only 65 bytes. The
 *    choice likely depends on CPU memory cache sizes.
 */

/*
 *----------------------------------------------------------------------
 *
 * BinaryEncodeHex --
 *
 *    Implement the [binary encode hex] binary encoding. clientData must be
 *    a table to convert values to hexadecimal digits.
 *
 * Results:
 *    Interp result set to an encoded byte array object 
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

static int
BinaryEncodeHex(
    ClientData clientData,
    Tcl_Interp *interp, 
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data = NULL;
    unsigned char *cursor = NULL;
    const char *digits = clientData;
    int offset = 0, count = 0;
      
    if (objc != 2) {
      Tcl_WrongNumArgs(interp, 1, objv, "data");
      return TCL_ERROR;
    }

    TclNewObj(resultObj);
    data = Tcl_GetByteArrayFromObj(objv[1], &count);
    cursor = Tcl_SetByteArrayLength(resultObj, count * 2);
    for (offset = 0; offset < count; ++offset) {
      *cursor++ = digits[((data[offset] >> 4) & 0x0f)];
      *cursor++ = digits[(data[offset] & 0x0f)];
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryDecodeHex --
 *
 *    Implement the [binary decode hex] binary encoding.
 *
 * Results:
 *    Interp result set to an decoded byte array object 
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

static int
BinaryDecodeHex(
    ClientData clientData,
    Tcl_Interp *interp, 
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor, c;
    int i, index, value, size, count = 0, cut = 0, strict = 0;
    enum {OPT_STRICT };
    static const char *optStrings[] = { "-strict", NULL };
      
    if (objc < 2 || objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "data");
      return TCL_ERROR;
    }
    for (i = 1; i < objc-1; ++i) {
      if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
            TCL_EXACT, &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch (index) {
      case OPT_STRICT: 
          strict = 1;
          break;
      }
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
          TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = (count + 1) / 2;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
      value = 0;
      for (i=0 ; i<2 ; i++) {
          if (data < dataend) {
            c = *data++;

            if (!isxdigit((int) c)) {
                if (strict) {
                  goto badChar;
                } else {
                  i--;
                  continue;
                }
            }
            value <<= 4;
            c -= '0';
            if (c > 9) {
                c += ('0' - 'A') + 10;
            }
            if (c > 16) {
                c += ('A' - 'a');
            }
            value |= (c & 0xf);
          } else {
            value <<= 4;
            ++cut;
          }
      }
      *cursor++ = UCHAR(value);
      value = 0;
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  badChar:
    TclDecrRefCount(resultObj);
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
          "invalid hexadecimal digit \"%c\" at position %d",
          c, (int) (data - datastart - 1)));
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryEncode64 --
 *
 *    This implements a generic 6 bit binary encoding. Input is broken into
 *    6 bit chunks and a lookup table passed in via clientData is used to
 *    turn these values into output characters. This is used to implement
 *    base64 and uuencode binary encodings.
 *
 * Results:
 *    Interp result set to an encoded byte array object 
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

#define OUTPUT(c) \
    do {                                  \
      *cursor++ = (c);                    \
      ++outindex;                         \
      if (maxlen > 0 && cursor != limit) {            \
          if (outindex == maxlen) {             \
            memcpy(cursor, wrapchar, wrapcharlen);    \
            cursor += wrapcharlen;              \
            outindex = 0;                       \
          }                               \
      }                                   \
      if (cursor > limit) {                     \
          Tcl_Panic("limit hit\n");             \
      }                                   \
    } while (0)

static int
BinaryEncode64(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj;
    unsigned char *data, *cursor, *limit;
    const char *digits = clientData;
    int maxlen = 0;
    const char *wrapchar = "\n";
    int wrapcharlen = 1;
    int offset, i, index, size, outindex = 0, count = 0;
    enum {OPT_MAXLEN, OPT_WRAPCHAR };
    static const char *optStrings[] = { "-maxlen", "-wrapchar", NULL };

    if (objc < 2 || objc%2 != 0) {
      Tcl_WrongNumArgs(interp, 1, objv, 
            "?-maxlen len? ?-wrapchar char? data");
      return TCL_ERROR;
    }
    for (i = 1; i < objc-1; i += 2) {
      if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
            TCL_EXACT, &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch (index) {
      case OPT_MAXLEN: 
          if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) {
            return TCL_ERROR;
          }
          break;
      case OPT_WRAPCHAR:
          wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen);
          if (wrapcharlen == 0) {
            maxlen = 0;
          }
          break;
      }
    }

    resultObj = Tcl_NewObj();
    data = Tcl_GetByteArrayFromObj(objv[objc-1], &count);
    if (count > 0) {
      size = (((count * 4) / 3) + 3) & ~3; /* ensure 4 byte chunks */
      if (maxlen > 0 && size > maxlen) {
          int adjusted = size + (wrapcharlen * (size / maxlen));

          if (size % maxlen == 0) {
            adjusted -= wrapcharlen;
          }
          size = adjusted;
      }
      cursor = Tcl_SetByteArrayLength(resultObj, size);
      limit = cursor + size;
      for (offset = 0; offset < count; offset+=3) {
          unsigned char d[3] = {0, 0, 0};

          for (i = 0; i < 3 && offset+i < count; ++i) {
            d[i] = data[offset + i];
          }
          OUTPUT(digits[d[0] >> 2]);
          OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]);
          if (offset+1 < count) {
            OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]);
          } else {
            OUTPUT(digits[64]);
          }
          if (offset+2 < count) {
            OUTPUT(digits[d[2] & 0x3f]);
          } else {
            OUTPUT(digits[64]);
          }
      }
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}
#undef OUTPUT

/*
 *----------------------------------------------------------------------
 *
 * BinaryDecodeUu --
 *
 *    Decode a uuencoded string.
 *
 * Results:
 *    Interp result set to an byte array object 
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

static int
BinaryDecodeUu(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend;
    unsigned char *begin, *cursor;
    int i, index, size, count = 0, cut = 0, strict = 0;
    char c;
    enum {OPT_STRICT };
    static const char *optStrings[] = { "-strict", NULL };
      
    if (objc < 2 || objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "data");
      return TCL_ERROR;
    }
    for (i = 1; i < objc-1; ++i) {
      if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
            TCL_EXACT, &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch (index) {
      case OPT_STRICT: 
          strict = 1;
          break;
      }
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
          TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
      char d[4] = {0, 0, 0, 0};

      for (i=0 ; i<4 ; i++) {
          if (data < dataend) {
            d[i] = c = *data++;
            if (c < 33 || c > 96) {
                if (strict) {
                  goto badUu;
                } else {
                  i--;
                  continue;
                }
            }
          } else {
            ++cut;
          }
      }
      *cursor++ = (((d[0] - 0x20) & 0x3f) << 2)
            | (((d[1] - 0x20) & 0x3f) >> 4);
      *cursor++ = (((d[1] - 0x20) & 0x3f) << 4)
            | (((d[2] - 0x20) & 0x3f) >> 2);
      *cursor++ = (((d[2] - 0x20) & 0x3f) << 6)
            | (((d[3] - 0x20) & 0x3f));
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  badUu:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
          "invalid uuencode character \"%c\" at position %d",
          c, (int) (data - datastart - 1)));
    TclDecrRefCount(resultObj);
    return TCL_ERROR;
}

/*
 *----------------------------------------------------------------------
 *
 * BinaryDecode64 --
 *
 *    Decode a base64 encoded string.
 *
 * Results:
 *    Interp result set to an byte array object 
 *
 * Side effects:
 *    None
 *
 *----------------------------------------------------------------------
 */

static int
BinaryDecode64(
    ClientData clientData,
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *resultObj = NULL;
    unsigned char *data, *datastart, *dataend, c;
    unsigned char *begin = NULL;
    unsigned char *cursor = NULL;
    int strict = 0;
    int i, index, size, cut = 0, count = 0;
    enum {OPT_STRICT };
    static const char *optStrings[] = { "-strict", NULL };
      
    if (objc < 2 || objc > 3) {
      Tcl_WrongNumArgs(interp, 1, objv, "data");
      return TCL_ERROR;
    }
    for (i = 1; i < objc-1; ++i) {
      if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option",
            TCL_EXACT, &index) != TCL_OK) {
          return TCL_ERROR;
      }
      switch (index) {
      case OPT_STRICT: 
          strict = 1;
          break;
      }
    }

    TclNewObj(resultObj);
    datastart = data = (unsigned char *)
          TclGetStringFromObj(objv[objc-1], &count);
    dataend = data + count;
    size = ((count + 3) & ~3) * 3 / 4;
    begin = cursor = Tcl_SetByteArrayLength(resultObj, size);
    while (data < dataend) {
      int i;
      unsigned long value = 0;

      for (i=0 ; i<4 ; i++) {
          if (data < dataend) {
            c = *data++;

            if (c >= 'A' && c <= 'Z') {
                value = (value << 6) | ((c - 'A') & 0x3f);
            } else if (c >= 'a' && c <= 'z') {
                value = (value << 6) | ((c - 'a' + 26) & 0x3f);
            } else if (c >= '0' && c <= '9') {
                value = (value << 6) | ((c - '0' + 52) & 0x3f);
            } else if (c == '+') {
                value = (value << 6) | 0x3e;
            } else if (c == '/') {
                value = (value << 6) | 0x3f;
            } else if (c == '=') {
                value <<= 6;
                if (cut < 2) {
                  ++cut;
                }
            } else {
                if (strict) {
                  goto bad64;
                }
                i--;
                continue;
            }
          } else {
            value <<= 6;
            ++cut;
          }
      }
      *cursor++ = UCHAR((value >> 16) & 0xff);
      *cursor++ = UCHAR((value >> 8) & 0xff);
      *cursor++ = UCHAR(value & 0xff);
    }
    Tcl_SetByteArrayLength(resultObj, cursor - begin - cut);
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;

  bad64:
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
          "invalid base64 character \"%c\" at position %d",
          (char) c, (int) (data - datastart - 1)));
    TclDecrRefCount(resultObj);
    return TCL_ERROR;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index