tclBinary.c

Go to the documentation of this file.
00001 /*
00002  * tclBinary.c --
00003  *
00004  *      This file contains the implementation of the "binary" Tcl built-in
00005  *      command and the Tcl binary data object.
00006  *
00007  * Copyright (c) 1997 by Sun Microsystems, Inc.
00008  * Copyright (c) 1998-1999 by Scriptics Corporation.
00009  *
00010  * See the file "license.terms" for information on usage and redistribution of
00011  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
00012  *
00013  * RCS: @(#) $Id: tclBinary.c,v 1.39 2007/12/13 15:23:15 dgp Exp $
00014  */
00015 
00016 #include "tclInt.h"
00017 #include "tommath.h"
00018 
00019 #include <math.h>
00020 
00021 /*
00022  * The following constants are used by GetFormatSpec to indicate various
00023  * special conditions in the parsing of a format specifier.
00024  */
00025 
00026 #define BINARY_ALL -1           /* Use all elements in the argument. */
00027 #define BINARY_NOCOUNT -2       /* No count was specified in format. */
00028 
00029 /*
00030  * The following flags may be ORed together and returned by GetFormatSpec
00031  */
00032 
00033 #define BINARY_SIGNED 0         /* Field to be read as signed data */
00034 #define BINARY_UNSIGNED 1       /* Field to be read as unsigned data */
00035 
00036 /*
00037  * The following defines the maximum number of different (integer) numbers
00038  * placed in the object cache by 'binary scan' before it bails out and
00039  * switches back to Plan A (creating a new object for each value.)
00040  * Theoretically, it would be possible to keep the cache about for the values
00041  * that are already in it, but that makes the code slower in practise when
00042  * overflow happens, and makes little odds the rest of the time (as measured
00043  * on my machine.) It is also slower (on the sample I tried at least) to grow
00044  * the cache to hold all items we might want to put in it; presumably the
00045  * extra cost of managing the memory for the enlarged table outweighs the
00046  * benefit from allocating fewer objects. This is probably because as the
00047  * number of objects increases, the likelihood of reuse of any particular one
00048  * drops, and there is very little gain from larger maximum cache sizes (the
00049  * value below is chosen to allow caching to work in full with conversion of
00050  * bytes.) - DKF
00051  */
00052 
00053 #define BINARY_SCAN_MAX_CACHE   260
00054 
00055 /*
00056  * Prototypes for local procedures defined in this file:
00057  */
00058 
00059 static void             DupByteArrayInternalRep(Tcl_Obj *srcPtr,
00060                             Tcl_Obj *copyPtr);
00061 static int              FormatNumber(Tcl_Interp *interp, int type,
00062                             Tcl_Obj *src, unsigned char **cursorPtr);
00063 static void             FreeByteArrayInternalRep(Tcl_Obj *objPtr);
00064 static int              GetFormatSpec(char **formatPtr, char *cmdPtr,
00065                             int *countPtr, int *flagsPtr);
00066 static Tcl_Obj *        ScanNumber(unsigned char *buffer, int type,
00067                             int flags, Tcl_HashTable **numberCachePtr);
00068 static int              SetByteArrayFromAny(Tcl_Interp *interp,
00069                             Tcl_Obj *objPtr);
00070 static void             UpdateStringOfByteArray(Tcl_Obj *listPtr);
00071 static void             DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
00072 static int              NeedReversing(int format);
00073 static void             CopyNumber(const void *from, void *to,
00074                             unsigned int length, int type);
00075 
00076 /*
00077  * The following object type represents an array of bytes. An array of bytes
00078  * is not equivalent to an internationalized string. Conceptually, a string is
00079  * an array of 16-bit quantities organized as a sequence of properly formed
00080  * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
00081  * Accessor functions are provided to convert a ByteArray to a String or a
00082  * String to a ByteArray. Two or more consecutive bytes in an array of bytes
00083  * may look like a single UTF-8 character if the array is casually treated as
00084  * a string. But obtaining the String from a ByteArray is guaranteed to
00085  * produced properly formed UTF-8 sequences so that there is a one-to-one map
00086  * between bytes and characters.
00087  *
00088  * Converting a ByteArray to a String proceeds by casting each byte in the
00089  * array to a 16-bit quantity, treating that number as a Unicode character,
00090  * and storing the UTF-8 version of that Unicode character in the String. For
00091  * ByteArrays consisting entirely of values 1..127, the corresponding String
00092  * representation is the same as the ByteArray representation.
00093  *
00094  * Converting a String to a ByteArray proceeds by getting the Unicode
00095  * representation of each character in the String, casting it to a byte by
00096  * truncating the upper 8 bits, and then storing the byte in the ByteArray.
00097  * Converting from ByteArray to String and back to ByteArray is not lossy, but
00098  * converting an arbitrary String to a ByteArray may be.
00099  */
00100 
00101 Tcl_ObjType tclByteArrayType = {
00102     "bytearray",
00103     FreeByteArrayInternalRep,
00104     DupByteArrayInternalRep,
00105     UpdateStringOfByteArray,
00106     SetByteArrayFromAny
00107 };
00108 
00109 /*
00110  * The following structure is the internal rep for a ByteArray object. Keeps
00111  * track of how much memory has been used and how much has been allocated for
00112  * the byte array to enable growing and shrinking of the ByteArray object with
00113  * fewer mallocs.
00114  */
00115 
00116 typedef struct ByteArray {
00117     int used;                   /* The number of bytes used in the byte
00118                                  * array. */
00119     int allocated;              /* The amount of space actually allocated
00120                                  * minus 1 byte. */
00121     unsigned char bytes[4];     /* The array of bytes. The actual size of this
00122                                  * field depends on the 'allocated' field
00123                                  * above. */
00124 } ByteArray;
00125 
00126 #define BYTEARRAY_SIZE(len) \
00127                 ((unsigned) (sizeof(ByteArray) - 4 + (len)))
00128 #define GET_BYTEARRAY(objPtr) \
00129                 ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
00130 #define SET_BYTEARRAY(objPtr, baPtr) \
00131                 (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
00132 
00133 
00134 /*
00135  *----------------------------------------------------------------------
00136  *
00137  * Tcl_NewByteArrayObj --
00138  *
00139  *      This procedure is creates a new ByteArray object and initializes it
00140  *      from the given array of bytes.
00141  *
00142  * Results:
00143  *      The newly create object is returned. This object will have no initial
00144  *      string representation. The returned object has a ref count of 0.
00145  *
00146  * Side effects:
00147  *      Memory allocated for new object and copy of byte array argument.
00148  *
00149  *----------------------------------------------------------------------
00150  */
00151 
00152 #ifdef TCL_MEM_DEBUG
00153 #undef Tcl_NewByteArrayObj
00154 
00155 Tcl_Obj *
00156 Tcl_NewByteArrayObj(
00157     const unsigned char *bytes, /* The array of bytes used to initialize the
00158                                  * new object. */
00159     int length)                 /* Length of the array of bytes, which must be
00160                                  * >= 0. */
00161 {
00162     return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
00163 }
00164 
00165 #else /* if not TCL_MEM_DEBUG */
00166 
00167 Tcl_Obj *
00168 Tcl_NewByteArrayObj(
00169     const unsigned char *bytes, /* The array of bytes used to initialize the
00170                                  * new object. */
00171     int length)                 /* Length of the array of bytes, which must be
00172                                  * >= 0. */
00173 {
00174     Tcl_Obj *objPtr;
00175 
00176     TclNewObj(objPtr);
00177     Tcl_SetByteArrayObj(objPtr, bytes, length);
00178     return objPtr;
00179 }
00180 #endif /* TCL_MEM_DEBUG */
00181 
00182 /*
00183  *----------------------------------------------------------------------
00184  *
00185  * Tcl_DbNewByteArrayObj --
00186  *
00187  *      This procedure is normally called when debugging: i.e., when
00188  *      TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
00189  *      above except that it calls Tcl_DbCkalloc directly with the file name
00190  *      and line number from its caller. This simplifies debugging since then
00191  *      the [memory active] command will report the correct file name and line
00192  *      number when reporting objects that haven't been freed.
00193  *
00194  *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
00195  *      result of calling Tcl_NewByteArrayObj.
00196  *
00197  * Results:
00198  *      The newly create object is returned. This object will have no initial
00199  *      string representation. The returned object has a ref count of 0.
00200  *
00201  * Side effects:
00202  *      Memory allocated for new object and copy of byte array argument.
00203  *
00204  *----------------------------------------------------------------------
00205  */
00206 
00207 #ifdef TCL_MEM_DEBUG
00208 
00209 Tcl_Obj *
00210 Tcl_DbNewByteArrayObj(
00211     const unsigned char *bytes, /* The array of bytes used to initialize the
00212                                  * new object. */
00213     int length,                 /* Length of the array of bytes, which must be
00214                                  * >= 0. */
00215     const char *file,           /* The name of the source file calling this
00216                                  * procedure; used for debugging. */
00217     int line)                   /* Line number in the source file; used for
00218                                  * debugging. */
00219 {
00220     Tcl_Obj *objPtr;
00221 
00222     TclDbNewObj(objPtr, file, line);
00223     Tcl_SetByteArrayObj(objPtr, bytes, length);
00224     return objPtr;
00225 }
00226 
00227 #else /* if not TCL_MEM_DEBUG */
00228 
00229 Tcl_Obj *
00230 Tcl_DbNewByteArrayObj(
00231     const unsigned char *bytes, /* The array of bytes used to initialize the
00232                                  * new object. */
00233     int length,                 /* Length of the array of bytes, which must be
00234                                  * >= 0. */
00235     const char *file,           /* The name of the source file calling this
00236                                  * procedure; used for debugging. */
00237     int line)                   /* Line number in the source file; used for
00238                                  * debugging. */
00239 {
00240     return Tcl_NewByteArrayObj(bytes, length);
00241 }
00242 #endif /* TCL_MEM_DEBUG */
00243 
00244 /*
00245  *---------------------------------------------------------------------------
00246  *
00247  * Tcl_SetByteArrayObj --
00248  *
00249  *      Modify an object to be a ByteArray object and to have the specified
00250  *      array of bytes as its value.
00251  *
00252  * Results:
00253  *      None.
00254  *
00255  * Side effects:
00256  *      The object's old string rep and internal rep is freed. Memory
00257  *      allocated for copy of byte array argument.
00258  *
00259  *----------------------------------------------------------------------
00260  */
00261 
00262 void
00263 Tcl_SetByteArrayObj(
00264     Tcl_Obj *objPtr,            /* Object to initialize as a ByteArray. */
00265     const unsigned char *bytes, /* The array of bytes to use as the new
00266                                  * value. */
00267     int length)                 /* Length of the array of bytes, which must be
00268                                  * >= 0. */
00269 {
00270     ByteArray *byteArrayPtr;
00271 
00272     if (Tcl_IsShared(objPtr)) {
00273         Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
00274     }
00275     TclFreeIntRep(objPtr);
00276     Tcl_InvalidateStringRep(objPtr);
00277 
00278     byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
00279     byteArrayPtr->used = length;
00280     byteArrayPtr->allocated = length;
00281     memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
00282 
00283     objPtr->typePtr = &tclByteArrayType;
00284     SET_BYTEARRAY(objPtr, byteArrayPtr);
00285 }
00286 
00287 /*
00288  *----------------------------------------------------------------------
00289  *
00290  * Tcl_GetByteArrayFromObj --
00291  *
00292  *      Attempt to get the array of bytes from the Tcl object. If the object
00293  *      is not already a ByteArray object, an attempt will be made to convert
00294  *      it to one.
00295  *
00296  * Results:
00297  *      Pointer to array of bytes representing the ByteArray object.
00298  *
00299  * Side effects:
00300  *      Frees old internal rep. Allocates memory for new internal rep.
00301  *
00302  *----------------------------------------------------------------------
00303  */
00304 
00305 unsigned char *
00306 Tcl_GetByteArrayFromObj(
00307     Tcl_Obj *objPtr,            /* The ByteArray object. */
00308     int *lengthPtr)             /* If non-NULL, filled with length of the
00309                                  * array of bytes in the ByteArray object. */
00310 {
00311     ByteArray *baPtr;
00312 
00313     if (objPtr->typePtr != &tclByteArrayType) {
00314         SetByteArrayFromAny(NULL, objPtr);
00315     }
00316     baPtr = GET_BYTEARRAY(objPtr);
00317 
00318     if (lengthPtr != NULL) {
00319         *lengthPtr = baPtr->used;
00320     }
00321     return (unsigned char *) baPtr->bytes;
00322 }
00323 
00324 /*
00325  *----------------------------------------------------------------------
00326  *
00327  * Tcl_SetByteArrayLength --
00328  *
00329  *      This procedure changes the length of the byte array for this object.
00330  *      Once the caller has set the length of the array, it is acceptable to
00331  *      directly modify the bytes in the array up until Tcl_GetStringFromObj()
00332  *      has been called on this object.
00333  *
00334  * Results:
00335  *      The new byte array of the specified length.
00336  *
00337  * Side effects:
00338  *      Allocates enough memory for an array of bytes of the requested size.
00339  *      When growing the array, the old array is copied to the new array; new
00340  *      bytes are undefined. When shrinking, the old array is truncated to the
00341  *      specified length.
00342  *
00343  *----------------------------------------------------------------------
00344  */
00345 
00346 unsigned char *
00347 Tcl_SetByteArrayLength(
00348     Tcl_Obj *objPtr,            /* The ByteArray object. */
00349     int length)                 /* New length for internal byte array. */
00350 {
00351     ByteArray *byteArrayPtr;
00352 
00353     if (Tcl_IsShared(objPtr)) {
00354         Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
00355     }
00356     if (objPtr->typePtr != &tclByteArrayType) {
00357         SetByteArrayFromAny(NULL, objPtr);
00358     }
00359 
00360     byteArrayPtr = GET_BYTEARRAY(objPtr);
00361     if (length > byteArrayPtr->allocated) {
00362         byteArrayPtr = (ByteArray *) ckrealloc(
00363                 (char *) byteArrayPtr, BYTEARRAY_SIZE(length));
00364         byteArrayPtr->allocated = length;
00365         SET_BYTEARRAY(objPtr, byteArrayPtr);
00366     }
00367     Tcl_InvalidateStringRep(objPtr);
00368     byteArrayPtr->used = length;
00369     return byteArrayPtr->bytes;
00370 }
00371 
00372 /*
00373  *----------------------------------------------------------------------
00374  *
00375  * SetByteArrayFromAny --
00376  *
00377  *      Generate the ByteArray internal rep from the string rep.
00378  *
00379  * Results:
00380  *      The return value is always TCL_OK.
00381  *
00382  * Side effects:
00383  *      A ByteArray object is stored as the internal rep of objPtr.
00384  *
00385  *----------------------------------------------------------------------
00386  */
00387 
00388 static int
00389 SetByteArrayFromAny(
00390     Tcl_Interp *interp,         /* Not used. */
00391     Tcl_Obj *objPtr)            /* The object to convert to type ByteArray. */
00392 {
00393     int length;
00394     char *src, *srcEnd;
00395     unsigned char *dst;
00396     ByteArray *byteArrayPtr;
00397     Tcl_UniChar ch;
00398 
00399     if (objPtr->typePtr != &tclByteArrayType) {
00400         src = TclGetStringFromObj(objPtr, &length);
00401         srcEnd = src + length;
00402 
00403         byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
00404         for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
00405             src += Tcl_UtfToUniChar(src, &ch);
00406             *dst++ = (unsigned char) ch;
00407         }
00408 
00409         byteArrayPtr->used = dst - byteArrayPtr->bytes;
00410         byteArrayPtr->allocated = length;
00411 
00412         TclFreeIntRep(objPtr);
00413         objPtr->typePtr = &tclByteArrayType;
00414         SET_BYTEARRAY(objPtr, byteArrayPtr);
00415     }
00416     return TCL_OK;
00417 }
00418 
00419 /*
00420  *----------------------------------------------------------------------
00421  *
00422  * FreeByteArrayInternalRep --
00423  *
00424  *      Deallocate the storage associated with a ByteArray data object's
00425  *      internal representation.
00426  *
00427  * Results:
00428  *      None.
00429  *
00430  * Side effects:
00431  *      Frees memory.
00432  *
00433  *----------------------------------------------------------------------
00434  */
00435 
00436 static void
00437 FreeByteArrayInternalRep(
00438     Tcl_Obj *objPtr)            /* Object with internal rep to free. */
00439 {
00440     ckfree((char *) GET_BYTEARRAY(objPtr));
00441 }
00442 
00443 /*
00444  *----------------------------------------------------------------------
00445  *
00446  * DupByteArrayInternalRep --
00447  *
00448  *      Initialize the internal representation of a ByteArray Tcl_Obj to a
00449  *      copy of the internal representation of an existing ByteArray object.
00450  *
00451  * Results:
00452  *      None.
00453  *
00454  * Side effects:
00455  *      Allocates memory.
00456  *
00457  *----------------------------------------------------------------------
00458  */
00459 
00460 static void
00461 DupByteArrayInternalRep(
00462     Tcl_Obj *srcPtr,            /* Object with internal rep to copy. */
00463     Tcl_Obj *copyPtr)           /* Object with internal rep to set. */
00464 {
00465     int length;
00466     ByteArray *srcArrayPtr, *copyArrayPtr;
00467 
00468     srcArrayPtr = GET_BYTEARRAY(srcPtr);
00469     length = srcArrayPtr->used;
00470 
00471     copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
00472     copyArrayPtr->used = length;
00473     copyArrayPtr->allocated = length;
00474     memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
00475     SET_BYTEARRAY(copyPtr, copyArrayPtr);
00476 
00477     copyPtr->typePtr = &tclByteArrayType;
00478 }
00479 
00480 /*
00481  *----------------------------------------------------------------------
00482  *
00483  * UpdateStringOfByteArray --
00484  *
00485  *      Update the string representation for a ByteArray data object. Note:
00486  *      This procedure does not invalidate an existing old string rep so
00487  *      storage will be lost if this has not already been done.
00488  *
00489  * Results:
00490  *      None.
00491  *
00492  * Side effects:
00493  *      The object's string is set to a valid string that results from the
00494  *      ByteArray-to-string conversion.
00495  *
00496  *      The object becomes a string object -- the internal rep is discarded
00497  *      and the typePtr becomes NULL.
00498  *
00499  *----------------------------------------------------------------------
00500  */
00501 
00502 static void
00503 UpdateStringOfByteArray(
00504     Tcl_Obj *objPtr)            /* ByteArray object whose string rep to
00505                                  * update. */
00506 {
00507     int i, length, size;
00508     unsigned char *src;
00509     char *dst;
00510     ByteArray *byteArrayPtr;
00511 
00512     byteArrayPtr = GET_BYTEARRAY(objPtr);
00513     src = byteArrayPtr->bytes;
00514     length = byteArrayPtr->used;
00515 
00516     /*
00517      * How much space will string rep need?
00518      */
00519 
00520     size = length;
00521     for (i = 0; i < length; i++) {
00522         if ((src[i] == 0) || (src[i] > 127)) {
00523             size++;
00524         }
00525     }
00526 
00527     dst = (char *) ckalloc((unsigned) (size + 1));
00528     objPtr->bytes = dst;
00529     objPtr->length = size;
00530 
00531     if (size == length) {
00532         memcpy(dst, src, (size_t) size);
00533         dst[size] = '\0';
00534     } else {
00535         for (i = 0; i < length; i++) {
00536             dst += Tcl_UniCharToUtf(src[i], dst);
00537         }
00538         *dst = '\0';
00539     }
00540 }
00541 
00542 /*
00543  *----------------------------------------------------------------------
00544  *
00545  * Tcl_BinaryObjCmd --
00546  *
00547  *      This procedure implements the "binary" Tcl command.
00548  *
00549  * Results:
00550  *      A standard Tcl result.
00551  *
00552  * Side effects:
00553  *      See the user documentation.
00554  *
00555  *----------------------------------------------------------------------
00556  */
00557 
00558 int
00559 Tcl_BinaryObjCmd(
00560     ClientData dummy,           /* Not used. */
00561     Tcl_Interp *interp,         /* Current interpreter. */
00562     int objc,                   /* Number of arguments. */
00563     Tcl_Obj *const objv[])      /* Argument objects. */
00564 {
00565     int arg;                    /* Index of next argument to consume. */
00566     int value = 0;              /* Current integer value to be packed.
00567                                  * Initialized to avoid compiler warning. */
00568     char cmd;                   /* Current format character. */
00569     int count;                  /* Count associated with current format
00570                                  * character. */
00571     int flags;                  /* Format field flags */
00572     char *format;               /* Pointer to current position in format
00573                                  * string. */
00574     Tcl_Obj *resultPtr = NULL;  /* Object holding result buffer. */
00575     unsigned char *buffer;      /* Start of result buffer. */
00576     unsigned char *cursor;      /* Current position within result buffer. */
00577     unsigned char *maxPos;      /* Greatest position within result buffer that
00578                                  * cursor has visited.*/
00579     const char *errorString;
00580     char *errorValue, *str;
00581     int offset, size, length, index;
00582     static const char *options[] = {
00583         "format",       "scan",         NULL
00584     };
00585     enum options {
00586         BINARY_FORMAT,  BINARY_SCAN
00587     };
00588 
00589     if (objc < 2) {
00590         Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
00591         return TCL_ERROR;
00592     }
00593 
00594     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
00595             &index) != TCL_OK) {
00596         return TCL_ERROR;
00597     }
00598 
00599     switch ((enum options) index) {
00600     case BINARY_FORMAT:
00601         if (objc < 3) {
00602             Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
00603             return TCL_ERROR;
00604         }
00605 
00606         /*
00607          * To avoid copying the data, we format the string in two passes. The
00608          * first pass computes the size of the output buffer. The second pass
00609          * places the formatted data into the buffer.
00610          */
00611 
00612         format = TclGetString(objv[2]);
00613         arg = 3;
00614         offset = 0;
00615         length = 0;
00616         while (*format != '\0') {
00617             str = format;
00618             flags = 0;
00619             if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
00620                 break;
00621             }
00622             switch (cmd) {
00623             case 'a':
00624             case 'A':
00625             case 'b':
00626             case 'B':
00627             case 'h':
00628             case 'H':
00629                 /*
00630                  * For string-type specifiers, the count corresponds to the
00631                  * number of bytes in a single argument.
00632                  */
00633 
00634                 if (arg >= objc) {
00635                     goto badIndex;
00636                 }
00637                 if (count == BINARY_ALL) {
00638                     Tcl_GetByteArrayFromObj(objv[arg], &count);
00639                 } else if (count == BINARY_NOCOUNT) {
00640                     count = 1;
00641                 }
00642                 arg++;
00643                 if (cmd == 'a' || cmd == 'A') {
00644                     offset += count;
00645                 } else if (cmd == 'b' || cmd == 'B') {
00646                     offset += (count + 7) / 8;
00647                 } else {
00648                     offset += (count + 1) / 2;
00649                 }
00650                 break;
00651             case 'c':
00652                 size = 1;
00653                 goto doNumbers;
00654             case 't':
00655             case 's':
00656             case 'S':
00657                 size = 2;
00658                 goto doNumbers;
00659             case 'n':
00660             case 'i':
00661             case 'I':
00662                 size = 4;
00663                 goto doNumbers;
00664             case 'm':
00665             case 'w':
00666             case 'W':
00667                 size = 8;
00668                 goto doNumbers;
00669             case 'r':
00670             case 'R':
00671             case 'f':
00672                 size = sizeof(float);
00673                 goto doNumbers;
00674             case 'q':
00675             case 'Q':
00676             case 'd':
00677                 size = sizeof(double);
00678 
00679             doNumbers:
00680                 if (arg >= objc) {
00681                     goto badIndex;
00682                 }
00683 
00684                 /*
00685                  * For number-type specifiers, the count corresponds to the
00686                  * number of elements in the list stored in a single argument.
00687                  * If no count is specified, then the argument is taken as a
00688                  * single non-list value.
00689                  */
00690 
00691                 if (count == BINARY_NOCOUNT) {
00692                     arg++;
00693                     count = 1;
00694                 } else {
00695                     int listc;
00696                     Tcl_Obj **listv;
00697 
00698                     /* The macro evals its args more than once: avoid arg++ */              
00699                     if (TclListObjGetElements(interp, objv[arg], &listc,
00700                             &listv) != TCL_OK) {
00701                         return TCL_ERROR;
00702                     }
00703                     arg++;
00704                     
00705                     if (count == BINARY_ALL) {
00706                         count = listc;
00707                     } else if (count > listc) {
00708                         Tcl_AppendResult(interp,
00709                                 "number of elements in list does not match count",
00710                                 NULL);
00711                         return TCL_ERROR;
00712                     }
00713                 }
00714                 offset += count*size;
00715                 break;
00716 
00717             case 'x':
00718                 if (count == BINARY_ALL) {
00719                     Tcl_AppendResult(interp,
00720                             "cannot use \"*\" in format string with \"x\"",
00721                             NULL);
00722                     return TCL_ERROR;
00723                 } else if (count == BINARY_NOCOUNT) {
00724                     count = 1;
00725                 }
00726                 offset += count;
00727                 break;
00728             case 'X':
00729                 if (count == BINARY_NOCOUNT) {
00730                     count = 1;
00731                 }
00732                 if ((count > offset) || (count == BINARY_ALL)) {
00733                     count = offset;
00734                 }
00735                 if (offset > length) {
00736                     length = offset;
00737                 }
00738                 offset -= count;
00739                 break;
00740             case '@':
00741                 if (offset > length) {
00742                     length = offset;
00743                 }
00744                 if (count == BINARY_ALL) {
00745                     offset = length;
00746                 } else if (count == BINARY_NOCOUNT) {
00747                     goto badCount;
00748                 } else {
00749                     offset = count;
00750                 }
00751                 break;
00752             default:
00753                 errorString = str;
00754                 goto badField;
00755             }
00756         }
00757         if (offset > length) {
00758             length = offset;
00759         }
00760         if (length == 0) {
00761             return TCL_OK;
00762         }
00763 
00764         /*
00765          * Prepare the result object by preallocating the caclulated number of
00766          * bytes and filling with nulls.
00767          */
00768 
00769         resultPtr = Tcl_NewObj();
00770         buffer = Tcl_SetByteArrayLength(resultPtr, length);
00771         memset(buffer, 0, (size_t) length);
00772 
00773         /*
00774          * Pack the data into the result object. Note that we can skip the
00775          * error checking during this pass, since we have already parsed the
00776          * string once.
00777          */
00778 
00779         arg = 3;
00780         format = TclGetString(objv[2]);
00781         cursor = buffer;
00782         maxPos = cursor;
00783         while (*format != 0) {
00784             flags = 0;
00785             if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
00786                 break;
00787             }
00788             if ((count == 0) && (cmd != '@')) {
00789                 arg++;
00790                 continue;
00791             }
00792             switch (cmd) {
00793             case 'a':
00794             case 'A': {
00795                 char pad = (char) (cmd == 'a' ? '\0' : ' ');
00796                 unsigned char *bytes;
00797 
00798                 bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
00799 
00800                 if (count == BINARY_ALL) {
00801                     count = length;
00802                 } else if (count == BINARY_NOCOUNT) {
00803                     count = 1;
00804                 }
00805                 if (length >= count) {
00806                     memcpy(cursor, bytes, (size_t) count);
00807                 } else {
00808                     memcpy(cursor, bytes, (size_t) length);
00809                     memset(cursor + length, pad, (size_t) (count - length));
00810                 }
00811                 cursor += count;
00812                 break;
00813             }
00814             case 'b':
00815             case 'B': {
00816                 unsigned char *last;
00817 
00818                 str = TclGetStringFromObj(objv[arg], &length);
00819                 arg++;
00820                 if (count == BINARY_ALL) {
00821                     count = length;
00822                 } else if (count == BINARY_NOCOUNT) {
00823                     count = 1;
00824                 }
00825                 last = cursor + ((count + 7) / 8);
00826                 if (count > length) {
00827                     count = length;
00828                 }
00829                 value = 0;
00830                 errorString = "binary";
00831                 if (cmd == 'B') {
00832                     for (offset = 0; offset < count; offset++) {
00833                         value <<= 1;
00834                         if (str[offset] == '1') {
00835                             value |= 1;
00836                         } else if (str[offset] != '0') {
00837                             errorValue = str;
00838                             Tcl_DecrRefCount(resultPtr);
00839                             goto badValue;
00840                         }
00841                         if (((offset + 1) % 8) == 0) {
00842                             *cursor++ = (unsigned char) value;
00843                             value = 0;
00844                         }
00845                     }
00846                 } else {
00847                     for (offset = 0; offset < count; offset++) {
00848                         value >>= 1;
00849                         if (str[offset] == '1') {
00850                             value |= 128;
00851                         } else if (str[offset] != '0') {
00852                             errorValue = str;
00853                             Tcl_DecrRefCount(resultPtr);
00854                             goto badValue;
00855                         }
00856                         if (!((offset + 1) % 8)) {
00857                             *cursor++ = (unsigned char) value;
00858                             value = 0;
00859                         }
00860                     }
00861                 }
00862                 if ((offset % 8) != 0) {
00863                     if (cmd == 'B') {
00864                         value <<= 8 - (offset % 8);
00865                     } else {
00866                         value >>= 8 - (offset % 8);
00867                     }
00868                     *cursor++ = (unsigned char) value;
00869                 }
00870                 while (cursor < last) {
00871                     *cursor++ = '\0';
00872                 }
00873                 break;
00874             }
00875             case 'h':
00876             case 'H': {
00877                 unsigned char *last;
00878                 int c;
00879 
00880                 str = TclGetStringFromObj(objv[arg], &length);
00881                 arg++;
00882                 if (count == BINARY_ALL) {
00883                     count = length;
00884                 } else if (count == BINARY_NOCOUNT) {
00885                     count = 1;
00886                 }
00887                 last = cursor + ((count + 1) / 2);
00888                 if (count > length) {
00889                     count = length;
00890                 }
00891                 value = 0;
00892                 errorString = "hexadecimal";
00893                 if (cmd == 'H') {
00894                     for (offset = 0; offset < count; offset++) {
00895                         value <<= 4;
00896                         if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
00897                             errorValue = str;
00898                             Tcl_DecrRefCount(resultPtr);
00899                             goto badValue;
00900                         }
00901                         c = str[offset] - '0';
00902                         if (c > 9) {
00903                             c += ('0' - 'A') + 10;
00904                         }
00905                         if (c > 16) {
00906                             c += ('A' - 'a');
00907                         }
00908                         value |= (c & 0xf);
00909                         if (offset % 2) {
00910                             *cursor++ = (char) value;
00911                             value = 0;
00912                         }
00913                     }
00914                 } else {
00915                     for (offset = 0; offset < count; offset++) {
00916                         value >>= 4;
00917 
00918                         if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
00919                             errorValue = str;
00920                             Tcl_DecrRefCount(resultPtr);
00921                             goto badValue;
00922                         }
00923                         c = str[offset] - '0';
00924                         if (c > 9) {
00925                             c += ('0' - 'A') + 10;
00926                         }
00927                         if (c > 16) {
00928                             c += ('A' - 'a');
00929                         }
00930                         value |= ((c << 4) & 0xf0);
00931                         if (offset % 2) {
00932                             *cursor++ = (unsigned char)(value & 0xff);
00933                             value = 0;
00934                         }
00935                     }
00936                 }
00937                 if (offset % 2) {
00938                     if (cmd == 'H') {
00939                         value <<= 4;
00940                     } else {
00941                         value >>= 4;
00942                     }
00943                     *cursor++ = (unsigned char) value;
00944                 }
00945 
00946                 while (cursor < last) {
00947                     *cursor++ = '\0';
00948                 }
00949                 break;
00950             }
00951             case 'c':
00952             case 't':
00953             case 's':
00954             case 'S':
00955             case 'n':
00956             case 'i':
00957             case 'I':
00958             case 'm':
00959             case 'w':
00960             case 'W':
00961             case 'r':
00962             case 'R':
00963             case 'd':
00964             case 'q':
00965             case 'Q':
00966             case 'f': {
00967                 int listc, i;
00968                 Tcl_Obj **listv;
00969 
00970                 if (count == BINARY_NOCOUNT) {
00971                     /*
00972                      * Note that we are casting away the const-ness of objv,
00973                      * but this is safe since we aren't going to modify the
00974                      * array.
00975                      */
00976 
00977                     listv = (Tcl_Obj**)(objv + arg);
00978                     listc = 1;
00979                     count = 1;
00980                 } else {
00981                     TclListObjGetElements(interp, objv[arg], &listc, &listv);
00982                     if (count == BINARY_ALL) {
00983                         count = listc;
00984                     }
00985                 }
00986                 arg++;
00987                 for (i = 0; i < count; i++) {
00988                     if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
00989                         Tcl_DecrRefCount(resultPtr);
00990                         return TCL_ERROR;
00991                     }
00992                 }
00993                 break;
00994             }
00995             case 'x':
00996                 if (count == BINARY_NOCOUNT) {
00997                     count = 1;
00998                 }
00999                 memset(cursor, 0, (size_t) count);
01000                 cursor += count;
01001                 break;
01002             case 'X':
01003                 if (cursor > maxPos) {
01004                     maxPos = cursor;
01005                 }
01006                 if (count == BINARY_NOCOUNT) {
01007                     count = 1;
01008                 }
01009                 if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
01010                     cursor = buffer;
01011                 } else {
01012                     cursor -= count;
01013                 }
01014                 break;
01015             case '@':
01016                 if (cursor > maxPos) {
01017                     maxPos = cursor;
01018                 }
01019                 if (count == BINARY_ALL) {
01020                     cursor = maxPos;
01021                 } else {
01022                     cursor = buffer + count;
01023                 }
01024                 break;
01025             }
01026         }
01027         Tcl_SetObjResult(interp, resultPtr);
01028         break;
01029     case BINARY_SCAN: {
01030         int i;
01031         Tcl_Obj *valuePtr, *elementPtr;
01032         Tcl_HashTable numberCacheHash;
01033         Tcl_HashTable *numberCachePtr;
01034 
01035         if (objc < 4) {
01036             Tcl_WrongNumArgs(interp, 2, objv,
01037                     "value formatString ?varName varName ...?");
01038             return TCL_ERROR;
01039         }
01040         numberCachePtr = &numberCacheHash;
01041         Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
01042         buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
01043         format = TclGetString(objv[3]);
01044         cursor = buffer;
01045         arg = 4;
01046         offset = 0;
01047         while (*format != '\0') {
01048             str = format;
01049             flags = 0;
01050             if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
01051                 goto done;
01052             }
01053             switch (cmd) {
01054             case 'a':
01055             case 'A': {
01056                 unsigned char *src;
01057 
01058                 if (arg >= objc) {
01059                     DeleteScanNumberCache(numberCachePtr);
01060                     goto badIndex;
01061                 }
01062                 if (count == BINARY_ALL) {
01063                     count = length - offset;
01064                 } else {
01065                     if (count == BINARY_NOCOUNT) {
01066                         count = 1;
01067                     }
01068                     if (count > (length - offset)) {
01069                         goto done;
01070                     }
01071                 }
01072 
01073                 src = buffer + offset;
01074                 size = count;
01075 
01076                 /*
01077                  * Trim trailing nulls and spaces, if necessary.
01078                  */
01079 
01080                 if (cmd == 'A') {
01081                     while (size > 0) {
01082                         if (src[size-1] != '\0' && src[size-1] != ' ') {
01083                             break;
01084                         }
01085                         size--;
01086                     }
01087                 }
01088 
01089                 /*
01090                  * Have to do this #ifdef-fery because (as part of defining
01091                  * Tcl_NewByteArrayObj) we removed the #def that hides this
01092                  * stuff normally. If this code ever gets copied to another
01093                  * file, it should be changed back to the simpler version.
01094                  */
01095 
01096 #ifdef TCL_MEM_DEBUG
01097                 valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
01098 #else
01099                 valuePtr = Tcl_NewByteArrayObj(src, size);
01100 #endif /* TCL_MEM_DEBUG */
01101 
01102                 resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
01103                         TCL_LEAVE_ERR_MSG);
01104                 arg++;
01105                 if (resultPtr == NULL) {
01106                     DeleteScanNumberCache(numberCachePtr);
01107                     return TCL_ERROR;
01108                 }
01109                 offset += count;
01110                 break;
01111             }
01112             case 'b':
01113             case 'B': {
01114                 unsigned char *src;
01115                 char *dest;
01116 
01117                 if (arg >= objc) {
01118                     DeleteScanNumberCache(numberCachePtr);
01119                     goto badIndex;
01120                 }
01121                 if (count == BINARY_ALL) {
01122                     count = (length - offset) * 8;
01123                 } else {
01124                     if (count == BINARY_NOCOUNT) {
01125                         count = 1;
01126                     }
01127                     if (count > (length - offset) * 8) {
01128                         goto done;
01129                     }
01130                 }
01131                 src = buffer + offset;
01132                 valuePtr = Tcl_NewObj();
01133                 Tcl_SetObjLength(valuePtr, count);
01134                 dest = TclGetString(valuePtr);
01135 
01136                 if (cmd == 'b') {
01137                     for (i = 0; i < count; i++) {
01138                         if (i % 8) {
01139                             value >>= 1;
01140                         } else {
01141                             value = *src++;
01142                         }
01143                         *dest++ = (char) ((value & 1) ? '1' : '0');
01144                     }
01145                 } else {
01146                     for (i = 0; i < count; i++) {
01147                         if (i % 8) {
01148                             value <<= 1;
01149                         } else {
01150                             value = *src++;
01151                         }
01152                         *dest++ = (char) ((value & 0x80) ? '1' : '0');
01153                     }
01154                 }
01155 
01156                 resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
01157                         TCL_LEAVE_ERR_MSG);
01158                 arg++;
01159                 if (resultPtr == NULL) {
01160                     DeleteScanNumberCache(numberCachePtr);
01161                     return TCL_ERROR;
01162                 }
01163                 offset += (count + 7) / 8;
01164                 break;
01165             }
01166             case 'h':
01167             case 'H': {
01168                 char *dest;
01169                 unsigned char *src;
01170                 int i;
01171                 static const char hexdigit[] = "0123456789abcdef";
01172 
01173                 if (arg >= objc) {
01174                     DeleteScanNumberCache(numberCachePtr);
01175                     goto badIndex;
01176                 }
01177                 if (count == BINARY_ALL) {
01178                     count = (length - offset)*2;
01179                 } else {
01180                     if (count == BINARY_NOCOUNT) {
01181                         count = 1;
01182                     }
01183                     if (count > (length - offset)*2) {
01184                         goto done;
01185                     }
01186                 }
01187                 src = buffer + offset;
01188                 valuePtr = Tcl_NewObj();
01189                 Tcl_SetObjLength(valuePtr, count);
01190                 dest = TclGetString(valuePtr);
01191 
01192                 if (cmd == 'h') {
01193                     for (i = 0; i < count; i++) {
01194                         if (i % 2) {
01195                             value >>= 4;
01196                         } else {
01197                             value = *src++;
01198                         }
01199                         *dest++ = hexdigit[value & 0xf];
01200                     }
01201                 } else {
01202                     for (i = 0; i < count; i++) {
01203                         if (i % 2) {
01204                             value <<= 4;
01205                         } else {
01206                             value = *src++;
01207                         }
01208                         *dest++ = hexdigit[(value >> 4) & 0xf];
01209                     }
01210                 }
01211 
01212                 resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
01213                         TCL_LEAVE_ERR_MSG);
01214                 arg++;
01215                 if (resultPtr == NULL) {
01216                     DeleteScanNumberCache(numberCachePtr);
01217                     return TCL_ERROR;
01218                 }
01219                 offset += (count + 1) / 2;
01220                 break;
01221             }
01222             case 'c':
01223                 size = 1;
01224                 goto scanNumber;
01225             case 't':
01226             case 's':
01227             case 'S':
01228                 size = 2;
01229                 goto scanNumber;
01230             case 'n':
01231             case 'i':
01232             case 'I':
01233                 size = 4;
01234                 goto scanNumber;
01235             case 'm':
01236             case 'w':
01237             case 'W':
01238                 size = 8;
01239                 goto scanNumber;
01240             case 'r':
01241             case 'R':
01242             case 'f':
01243                 size = sizeof(float);
01244                 goto scanNumber;
01245             case 'q':
01246             case 'Q':
01247             case 'd': {
01248                 unsigned char *src;
01249 
01250                 size = sizeof(double);
01251                 /* fall through */
01252 
01253             scanNumber:
01254                 if (arg >= objc) {
01255                     DeleteScanNumberCache(numberCachePtr);
01256                     goto badIndex;
01257                 }
01258                 if (count == BINARY_NOCOUNT) {
01259                     if ((length - offset) < size) {
01260                         goto done;
01261                     }
01262                     valuePtr = ScanNumber(buffer+offset, cmd, flags,
01263                             &numberCachePtr);
01264                     offset += size;
01265                 } else {
01266                     if (count == BINARY_ALL) {
01267                         count = (length - offset) / size;
01268                     }
01269                     if ((length - offset) < (count * size)) {
01270                         goto done;
01271                     }
01272                     valuePtr = Tcl_NewObj();
01273                     src = buffer+offset;
01274                     for (i = 0; i < count; i++) {
01275                         elementPtr = ScanNumber(src, cmd, flags,
01276                                 &numberCachePtr);
01277                         src += size;
01278                         Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
01279                     }
01280                     offset += count*size;
01281                 }
01282 
01283                 resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
01284                         TCL_LEAVE_ERR_MSG);
01285                 arg++;
01286                 if (resultPtr == NULL) {
01287                     DeleteScanNumberCache(numberCachePtr);
01288                     return TCL_ERROR;
01289                 }
01290                 break;
01291             }
01292             case 'x':
01293                 if (count == BINARY_NOCOUNT) {
01294                     count = 1;
01295                 }
01296                 if ((count == BINARY_ALL) || (count > (length - offset))) {
01297                     offset = length;
01298                 } else {
01299                     offset += count;
01300                 }
01301                 break;
01302             case 'X':
01303                 if (count == BINARY_NOCOUNT) {
01304                     count = 1;
01305                 }
01306                 if ((count == BINARY_ALL) || (count > offset)) {
01307                     offset = 0;
01308                 } else {
01309                     offset -= count;
01310                 }
01311                 break;
01312             case '@':
01313                 if (count == BINARY_NOCOUNT) {
01314                     DeleteScanNumberCache(numberCachePtr);
01315                     goto badCount;
01316                 }
01317                 if ((count == BINARY_ALL) || (count > length)) {
01318                     offset = length;
01319                 } else {
01320                     offset = count;
01321                 }
01322                 break;
01323             default:
01324                 DeleteScanNumberCache(numberCachePtr);
01325                 errorString = str;
01326                 goto badField;
01327             }
01328         }
01329 
01330         /*
01331          * Set the result to the last position of the cursor.
01332          */
01333 
01334     done:
01335         Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
01336         DeleteScanNumberCache(numberCachePtr);
01337         break;
01338     }
01339     }
01340     return TCL_OK;
01341 
01342   badValue:
01343     Tcl_ResetResult(interp);
01344     Tcl_AppendResult(interp, "expected ", errorString,
01345             " string but got \"", errorValue, "\" instead", NULL);
01346     return TCL_ERROR;
01347 
01348   badCount:
01349     errorString = "missing count for \"@\" field specifier";
01350     goto error;
01351 
01352   badIndex:
01353     errorString = "not enough arguments for all format specifiers";
01354     goto error;
01355 
01356   badField:
01357     {
01358         Tcl_UniChar ch;
01359         char buf[TCL_UTF_MAX + 1];
01360 
01361         Tcl_UtfToUniChar(errorString, &ch);
01362         buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
01363         Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
01364         return TCL_ERROR;
01365     }
01366 
01367   error:
01368     Tcl_AppendResult(interp, errorString, NULL);
01369     return TCL_ERROR;
01370 }
01371 
01372 /*
01373  *----------------------------------------------------------------------
01374  *
01375  * GetFormatSpec --
01376  *
01377  *      This function parses the format strings used in the binary format and
01378  *      scan commands.
01379  *
01380  * Results:
01381  *      Moves the formatPtr to the start of the next command. Returns the
01382  *      current command character and count in cmdPtr and countPtr. The count
01383  *      is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
01384  *      if no count was specified. Returns 1 on success, or 0 if the string
01385  *      did not have a format specifier.
01386  *
01387  * Side effects:
01388  *      None.
01389  *
01390  *----------------------------------------------------------------------
01391  */
01392 
01393 static int
01394 GetFormatSpec(
01395     char **formatPtr,           /* Pointer to format string. */
01396     char *cmdPtr,               /* Pointer to location of command char. */
01397     int *countPtr,              /* Pointer to repeat count value. */
01398     int *flagsPtr)              /* Pointer to field flags */
01399 {
01400     /*
01401      * Skip any leading blanks.
01402      */
01403 
01404     while (**formatPtr == ' ') {
01405         (*formatPtr)++;
01406     }
01407 
01408     /*
01409      * The string was empty, except for whitespace, so fail.
01410      */
01411 
01412     if (!(**formatPtr)) {
01413         return 0;
01414     }
01415 
01416     /*
01417      * Extract the command character and any trailing digits or '*'.
01418      */
01419 
01420     *cmdPtr = **formatPtr;
01421     (*formatPtr)++;
01422     if (**formatPtr == 'u') {
01423         (*formatPtr)++;
01424         (*flagsPtr) |= BINARY_UNSIGNED;
01425     }
01426     if (**formatPtr == '*') {
01427         (*formatPtr)++;
01428         (*countPtr) = BINARY_ALL;
01429     } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
01430         (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
01431     } else {
01432         (*countPtr) = BINARY_NOCOUNT;
01433     }
01434     return 1;
01435 }
01436 
01437 /*
01438  *----------------------------------------------------------------------
01439  *
01440  * NeedReversing --
01441  *
01442  *      This routine determines, if bytes of a number need to be re-ordered,
01443  *      and returns a numeric code indicating the re-ordering to be done.
01444  *      This depends on the endiannes of the machine and the desired format.
01445  *      It is in effect a table (whose contents depend on the endianness of
01446  *      the system) describing whether a value needs reversing or not. Anyone
01447  *      porting the code to a big-endian platform should take care to make
01448  *      sure that they define WORDS_BIGENDIAN though this is already done by
01449  *      configure for the Unix build; little-endian platforms (including
01450  *      Windows) don't need to do anything.
01451  *
01452  * Results:
01453  *      0       No re-ordering needed.
01454  *      1       Reverse the bytes:      01234567 <-> 76543210 (little to big)
01455  *      2       Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little)
01456  *      3       Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big)
01457  *
01458  * Side effects:
01459  *      None
01460  *
01461  *----------------------------------------------------------------------
01462  */
01463 
01464 static int
01465 NeedReversing(
01466     int format)
01467 {
01468     switch (format) {
01469         /* native floats and doubles: never reverse */
01470     case 'd':
01471     case 'f':
01472         /* big endian ints: never reverse */
01473     case 'I':
01474     case 'S':
01475     case 'W':
01476 #ifdef WORDS_BIGENDIAN
01477         /* native ints: reverse if we're little-endian */
01478     case 'n':
01479     case 't':
01480     case 'm':
01481         /* f: reverse if we're little-endian */
01482     case 'Q':
01483     case 'R':
01484 #else /* !WORDS_BIGENDIAN */
01485         /* small endian floats: reverse if we're big-endian */
01486     case 'r':
01487 #endif /* WORDS_BIGENDIAN */
01488         return 0;
01489 
01490 #ifdef WORDS_BIGENDIAN
01491         /* small endian floats: reverse if we're big-endian */
01492     case 'q':
01493     case 'r':
01494 #else /* !WORDS_BIGENDIAN */
01495         /* native ints: reverse if we're little-endian */
01496     case 'n':
01497     case 't':
01498     case 'm':
01499         /* f: reverse if we're little-endian */
01500     case 'R':
01501 #endif /* WORDS_BIGENDIAN */
01502         /* small endian ints: always reverse */
01503     case 'i':
01504     case 's':
01505     case 'w':
01506         return 1;
01507 
01508 #ifndef WORDS_BIGENDIAN
01509     /*
01510      * The Q and q formats need special handling to account for the unusual
01511      * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
01512      * little-endian, but also reverse word order.
01513      */
01514 
01515     case 'Q':
01516         if (TclNokia770Doubles()) {
01517             return 3;
01518         }
01519         return 1;
01520     case 'q':
01521         if (TclNokia770Doubles()) {
01522             return 2;
01523         }
01524         return 0;
01525 #endif
01526     }
01527 
01528     Tcl_Panic("unexpected fallthrough");
01529     return 0;
01530 }
01531 
01532 /*
01533  *----------------------------------------------------------------------
01534  *
01535  * CopyNumber --
01536  *
01537  *      This routine is called by FormatNumber and ScanNumber to copy a
01538  *      floating-point number. If required, bytes are reversed while copying.
01539  *      The behaviour is only fully defined when used with IEEE float and
01540  *      double values (guaranteed to be 4 and 8 bytes long, respectively.)
01541  *
01542  * Results:
01543  *      None
01544  *
01545  * Side effects:
01546  *      Copies length bytes
01547  *
01548  *----------------------------------------------------------------------
01549  */
01550 
01551 static void
01552 CopyNumber(
01553     const void *from,           /* source */
01554     void *to,                   /* destination */
01555     unsigned int length,        /* Number of bytes to copy */
01556     int type)                   /* What type of thing are we copying? */
01557 {
01558     switch (NeedReversing(type)) {
01559     case 0: 
01560         memcpy(to, from, length);
01561         break;
01562     case 1: {
01563         const unsigned char *fromPtr = from;
01564         unsigned char *toPtr = to;
01565 
01566         switch (length) {
01567         case 4:
01568             toPtr[0] = fromPtr[3];
01569             toPtr[1] = fromPtr[2];
01570             toPtr[2] = fromPtr[1];
01571             toPtr[3] = fromPtr[0];
01572             break;
01573         case 8:
01574             toPtr[0] = fromPtr[7];
01575             toPtr[1] = fromPtr[6];
01576             toPtr[2] = fromPtr[5];
01577             toPtr[3] = fromPtr[4];
01578             toPtr[4] = fromPtr[3];
01579             toPtr[5] = fromPtr[2];
01580             toPtr[6] = fromPtr[1];
01581             toPtr[7] = fromPtr[0];
01582             break;
01583         }
01584         break;
01585     }
01586     case 2: {
01587         const unsigned char *fromPtr = from;
01588         unsigned char *toPtr = to;
01589 
01590         toPtr[0] = fromPtr[4];
01591         toPtr[1] = fromPtr[5];
01592         toPtr[2] = fromPtr[6];
01593         toPtr[3] = fromPtr[7];
01594         toPtr[4] = fromPtr[0];
01595         toPtr[5] = fromPtr[1];
01596         toPtr[6] = fromPtr[2];
01597         toPtr[7] = fromPtr[3];
01598         break;
01599     }
01600     case 3: {
01601         const unsigned char *fromPtr = from;
01602         unsigned char *toPtr = to;
01603 
01604         toPtr[0] = fromPtr[3];
01605         toPtr[1] = fromPtr[2];
01606         toPtr[2] = fromPtr[1];
01607         toPtr[3] = fromPtr[0];
01608         toPtr[4] = fromPtr[7];
01609         toPtr[5] = fromPtr[6];
01610         toPtr[6] = fromPtr[5];
01611         toPtr[7] = fromPtr[4];
01612         break;
01613     }
01614     }
01615 }
01616 
01617 /*
01618  *----------------------------------------------------------------------
01619  *
01620  * FormatNumber --
01621  *
01622  *      This routine is called by Tcl_BinaryObjCmd to format a number into a
01623  *      location pointed at by cursor.
01624  *
01625  * Results:
01626  *      A standard Tcl result.
01627  *
01628  * Side effects:
01629  *      Moves the cursor to the next location to be written into.
01630  *
01631  *----------------------------------------------------------------------
01632  */
01633 
01634 static int
01635 FormatNumber(
01636     Tcl_Interp *interp,         /* Current interpreter, used to report
01637                                  * errors. */
01638     int type,                   /* Type of number to format. */
01639     Tcl_Obj *src,               /* Number to format. */
01640     unsigned char **cursorPtr)  /* Pointer to index into destination buffer. */
01641 {
01642     long value;
01643     double dvalue;
01644     Tcl_WideInt wvalue;
01645     float fvalue;
01646 
01647     switch (type) {
01648     case 'd':
01649     case 'q':
01650     case 'Q':
01651         /*
01652          * Double-precision floating point values. Tcl_GetDoubleFromObj
01653          * returns TCL_ERROR for NaN, but we can check by comparing the
01654          * object's type pointer.
01655          */
01656 
01657         if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
01658             if (src->typePtr != &tclDoubleType) {
01659                 return TCL_ERROR;
01660             }
01661             dvalue = src->internalRep.doubleValue;
01662         }
01663         CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
01664         *cursorPtr += sizeof(double);
01665         return TCL_OK;
01666 
01667     case 'f':
01668     case 'r':
01669     case 'R':
01670         /*
01671          * Single-precision floating point values. Tcl_GetDoubleFromObj
01672          * returns TCL_ERROR for NaN, but we can check by comparing the
01673          * object's type pointer.
01674          */
01675 
01676         if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
01677             if (src->typePtr != &tclDoubleType) {
01678                 return TCL_ERROR;
01679             }
01680             dvalue = src->internalRep.doubleValue;
01681         }
01682 
01683         /*
01684          * Because some compilers will generate floating point exceptions on
01685          * an overflow cast (e.g. Borland), we restrict the values to the
01686          * valid range for float.
01687          */
01688 
01689         if (fabs(dvalue) > (double)FLT_MAX) {
01690             fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
01691         } else {
01692             fvalue = (float) dvalue;
01693         }
01694         CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
01695         *cursorPtr += sizeof(float);
01696         return TCL_OK;
01697 
01698         /*
01699          * 64-bit integer values.
01700          */
01701     case 'w':
01702     case 'W':
01703     case 'm':
01704         if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
01705             return TCL_ERROR;
01706         }
01707         if (NeedReversing(type)) {
01708             *(*cursorPtr)++ = (unsigned char) wvalue;
01709             *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
01710             *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
01711             *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
01712             *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
01713             *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
01714             *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
01715             *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
01716         } else {
01717             *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
01718             *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
01719             *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
01720             *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
01721             *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
01722             *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
01723             *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
01724             *(*cursorPtr)++ = (unsigned char) wvalue;
01725         }
01726         return TCL_OK;
01727 
01728         /*
01729          * 32-bit integer values.
01730          */
01731     case 'i':
01732     case 'I':
01733     case 'n':
01734         if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
01735             return TCL_ERROR;
01736         }
01737         if (NeedReversing(type)) {
01738             *(*cursorPtr)++ = (unsigned char) value;
01739             *(*cursorPtr)++ = (unsigned char) (value >> 8);
01740             *(*cursorPtr)++ = (unsigned char) (value >> 16);
01741             *(*cursorPtr)++ = (unsigned char) (value >> 24);
01742         } else {
01743             *(*cursorPtr)++ = (unsigned char) (value >> 24);
01744             *(*cursorPtr)++ = (unsigned char) (value >> 16);
01745             *(*cursorPtr)++ = (unsigned char) (value >> 8);
01746             *(*cursorPtr)++ = (unsigned char) value;
01747         }
01748         return TCL_OK;
01749 
01750         /*
01751          * 16-bit integer values.
01752          */
01753     case 's':
01754     case 'S':
01755     case 't':
01756         if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
01757             return TCL_ERROR;
01758         }
01759         if (NeedReversing(type)) {
01760             *(*cursorPtr)++ = (unsigned char) value;
01761             *(*cursorPtr)++ = (unsigned char) (value >> 8);
01762         } else {
01763             *(*cursorPtr)++ = (unsigned char) (value >> 8);
01764             *(*cursorPtr)++ = (unsigned char) value;
01765         }
01766         return TCL_OK;
01767 
01768         /*
01769          * 8-bit integer values.
01770          */
01771     case 'c':
01772         if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
01773             return TCL_ERROR;
01774         }
01775         *(*cursorPtr)++ = (unsigned char) value;
01776         return TCL_OK;
01777 
01778     default:
01779         Tcl_Panic("unexpected fallthrough");
01780         return TCL_ERROR;
01781     }
01782 }
01783 
01784 /*
01785  *----------------------------------------------------------------------
01786  *
01787  * ScanNumber --
01788  *
01789  *      This routine is called by Tcl_BinaryObjCmd to scan a number out of a
01790  *      buffer.
01791  *
01792  * Results:
01793  *      Returns a newly created object containing the scanned number. This
01794  *      object has a ref count of zero.
01795  *
01796  * Side effects:
01797  *      Might reuse an object in the number cache, place a new object in the
01798  *      cache, or delete the cache and set the reference to it (itself passed
01799  *      in by reference) to NULL.
01800  *
01801  *----------------------------------------------------------------------
01802  */
01803 
01804 static Tcl_Obj *
01805 ScanNumber(
01806     unsigned char *buffer,      /* Buffer to scan number from. */
01807     int type,                   /* Format character from "binary scan" */
01808     int flags,                  /* Format field flags */
01809     Tcl_HashTable **numberCachePtrPtr)
01810                                 /* Place to look for cache of scanned
01811                                  * value objects, or NULL if too many
01812                                  * different numbers have been scanned. */
01813 {
01814     long value;
01815     float fvalue;
01816     double dvalue;
01817     Tcl_WideUInt uwvalue;
01818 
01819     /*
01820      * We cannot rely on the compiler to properly sign extend integer values
01821      * when we cast from smaller values to larger values because we don't know
01822      * the exact size of the integer types. So, we have to handle sign
01823      * extension explicitly by checking the high bit and padding with 1's as
01824      * needed. This practice is disabled if the BINARY_UNSIGNED flag is set.
01825      */
01826 
01827     switch (type) {
01828     case 'c':
01829         /*
01830          * Characters need special handling. We want to produce a signed
01831          * result, but on some platforms (such as AIX) chars are unsigned. To
01832          * deal with this, check for a value that should be negative but
01833          * isn't.
01834          */
01835 
01836         value = buffer[0];
01837         if (!(flags & BINARY_UNSIGNED)) {
01838             if (value & 0x80) {
01839                 value |= -0x100;
01840             }
01841         }
01842         goto returnNumericObject;
01843 
01844         /*
01845          * 16-bit numeric values. We need the sign extension trick (see above)
01846          * here as well.
01847          */
01848 
01849     case 's':
01850     case 'S':
01851     case 't':
01852         if (NeedReversing(type)) {
01853             value = (long) (buffer[0] + (buffer[1] << 8));
01854         } else {
01855             value = (long) (buffer[1] + (buffer[0] << 8));
01856         }
01857         if (!(flags & BINARY_UNSIGNED)) {
01858             if (value & 0x8000) {
01859                 value |= -0x10000;
01860             }
01861         }
01862         goto returnNumericObject;
01863 
01864         /*
01865          * 32-bit numeric values.
01866          */
01867 
01868     case 'i':
01869     case 'I':
01870     case 'n':
01871         if (NeedReversing(type)) {
01872             value = (long) (buffer[0]
01873                     + (buffer[1] << 8)
01874                     + (buffer[2] << 16)
01875                     + (((long)buffer[3]) << 24));
01876         } else {
01877             value = (long) (buffer[3]
01878                     + (buffer[2] << 8)
01879                     + (buffer[1] << 16)
01880                     + (((long)buffer[0]) << 24));
01881         }
01882 
01883         /*
01884          * Check to see if the value was sign extended properly on systems
01885          * where an int is more than 32-bits.
01886          * We avoid caching unsigned integers as we cannot distinguish between
01887          * 32bit signed and unsigned in the hash (short and char are ok).
01888          */
01889 
01890         if (flags & BINARY_UNSIGNED) {
01891             return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
01892         }
01893         if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
01894             value -= (((unsigned int)1)<<31);
01895             value -= (((unsigned int)1)<<31);
01896         }
01897 
01898     returnNumericObject:
01899         if (*numberCachePtrPtr == NULL) {
01900             return Tcl_NewLongObj(value);
01901         } else {
01902             register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
01903             register Tcl_HashEntry *hPtr;
01904             int isNew;
01905 
01906             hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
01907             if (!isNew) {
01908                 return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
01909             }
01910             if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
01911                 register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
01912 
01913                 Tcl_IncrRefCount(objPtr);
01914                 Tcl_SetHashValue(hPtr, (ClientData) objPtr);
01915                 return objPtr;
01916             }
01917 
01918             /*
01919              * We've overflowed the cache! Someone's parsing a LOT of varied
01920              * binary data in a single call! Bail out by switching back to the
01921              * old behaviour for the rest of the scan.
01922              *
01923              * Note that anyone just using the 'c' conversion (for bytes)
01924              * cannot trigger this.
01925              */
01926 
01927             DeleteScanNumberCache(tablePtr);
01928             *numberCachePtrPtr = NULL;
01929             return Tcl_NewLongObj(value);
01930         }
01931 
01932         /*
01933          * Do not cache wide (64-bit) values; they are already too large to
01934          * use as keys.
01935          */
01936 
01937     case 'w':
01938     case 'W':
01939     case 'm':
01940         if (NeedReversing(type)) {
01941             uwvalue = ((Tcl_WideUInt) buffer[0])
01942                     | (((Tcl_WideUInt) buffer[1]) << 8)
01943                     | (((Tcl_WideUInt) buffer[2]) << 16)
01944                     | (((Tcl_WideUInt) buffer[3]) << 24)
01945                     | (((Tcl_WideUInt) buffer[4]) << 32)
01946                     | (((Tcl_WideUInt) buffer[5]) << 40)
01947                     | (((Tcl_WideUInt) buffer[6]) << 48)
01948                     | (((Tcl_WideUInt) buffer[7]) << 56);
01949         } else {
01950             uwvalue = ((Tcl_WideUInt) buffer[7])
01951                     | (((Tcl_WideUInt) buffer[6]) << 8)
01952                     | (((Tcl_WideUInt) buffer[5]) << 16)
01953                     | (((Tcl_WideUInt) buffer[4]) << 24)
01954                     | (((Tcl_WideUInt) buffer[3]) << 32)
01955                     | (((Tcl_WideUInt) buffer[2]) << 40)
01956                     | (((Tcl_WideUInt) buffer[1]) << 48)
01957                     | (((Tcl_WideUInt) buffer[0]) << 56);
01958         }
01959         if (flags & BINARY_UNSIGNED) {
01960             Tcl_Obj *bigObj = NULL;
01961             mp_int big;
01962 
01963             TclBNInitBignumFromWideUInt(&big, uwvalue);
01964             bigObj = Tcl_NewBignumObj(&big);
01965             return bigObj;
01966         }
01967         return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
01968 
01969         /*
01970          * Do not cache double values; they are already too large to use as
01971          * keys and the values stored are utterly incompatible with the
01972          * integer part of the cache.
01973          */
01974 
01975         /*
01976          * 32-bit IEEE single-precision floating point.
01977          */
01978 
01979     case 'f':
01980     case 'R':
01981     case 'r':
01982         CopyNumber(buffer, &fvalue, sizeof(float), type);
01983         return Tcl_NewDoubleObj(fvalue);
01984 
01985         /*
01986          * 64-bit IEEE double-precision floating point.
01987          */
01988 
01989     case 'd':
01990     case 'Q':
01991     case 'q':
01992         CopyNumber(buffer, &dvalue, sizeof(double), type);
01993         return Tcl_NewDoubleObj(dvalue);
01994     }
01995     return NULL;
01996 }
01997 
01998 /*
01999  *----------------------------------------------------------------------
02000  *
02001  * DeleteScanNumberCache --
02002  *
02003  *      Deletes the hash table acting as a scan number cache.
02004  *
02005  * Results:
02006  *      None
02007  *
02008  * Side effects:
02009  *      Decrements the reference counts of the objects in the cache.
02010  *
02011  *----------------------------------------------------------------------
02012  */
02013 
02014 static void
02015 DeleteScanNumberCache(
02016     Tcl_HashTable *numberCachePtr)
02017                                 /* Pointer to the hash table, or NULL (when
02018                                  * the cache has already been deleted due to
02019                                  * overflow.) */
02020 {
02021     Tcl_HashEntry *hEntry;
02022     Tcl_HashSearch search;
02023 
02024     if (numberCachePtr == NULL) {
02025         return;
02026     }
02027 
02028     hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
02029     while (hEntry != NULL) {
02030         register Tcl_Obj *value = Tcl_GetHashValue(hEntry);
02031 
02032         if (value != NULL) {
02033             Tcl_DecrRefCount(value);
02034         }
02035         hEntry = Tcl_NextHashEntry(&search);
02036     }
02037     Tcl_DeleteHashTable(numberCachePtr);
02038 }
02039 
02040 /*
02041  * Local Variables:
02042  * mode: c
02043  * c-basic-offset: 4
02044  * fill-column: 78
02045  * End:
02046  */



Generated on Wed Mar 12 12:18:11 2008 by  doxygen 1.5.1