开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Windows编程 > 通讯编程 > 查看源码
tclBinary.c
资源名称：ns-allinone-2.33.tar.gz　[点击查看]
上传用户：rrhhcc
上传日期：2015-12-11
资源大小：54129k
文件大小：45k
源码类别：

通讯编程

开发平台：

Visual C++

tclBinary.c：源码内容
  1. /* 
  2.  * tclBinary.c --
  3.  *
  4.  * This file contains the implementation of the "binary" Tcl built-in
  5.  * command and the Tcl binary data object.
  6.  *
  7.  * Copyright (c) 1997 by Sun Microsystems, Inc.
  8.  * Copyright (c) 1998-1999 by Scriptics Corporation.
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * RCS: @(#) $Id: tclBinary.c,v 1.13.2.5 2007/06/30 13:56:23 dkf Exp $
  14.  */
  16. #include "tclInt.h"
  17. #include "tclPort.h"
  18. #include <math.h>
  20. /*
  21.  * The following constants are used by GetFormatSpec to indicate various
  22.  * special conditions in the parsing of a format specifier.
  23.  */
  25. #define BINARY_ALL -1 /* Use all elements in the argument. */
  26. #define BINARY_NOCOUNT -2 /* No count was specified in format. */
  28. /*
  29.  * The following defines the maximum number of different (integer)
  30.  * numbers placed in the object cache by 'binary scan' before it bails
  31.  * out and switches back to Plan A (creating a new object for each
  32.  * value.)  Theoretically, it would be possible to keep the cache
  33.  * about for the values that are already in it, but that makes the
  34.  * code slower in practise when overflow happens, and makes little
  35.  * odds the rest of the time (as measured on my machine.)  It is also
  36.  * slower (on the sample I tried at least) to grow the cache to hold
  37.  * all items we might want to put in it; presumably the extra cost of
  38.  * managing the memory for the enlarged table outweighs the benefit
  39.  * from allocating fewer objects.  This is probably because as the
  40.  * number of objects increases, the likelihood of reuse of any
  41.  * particular one drops, and there is very little gain from larger
  42.  * maximum cache sizes (the value below is chosen to allow caching to
  43.  * work in full with conversion of bytes.) - DKF
  44.  */
  46. #define BINARY_SCAN_MAX_CACHE 260
  48. /*
  49.  * Prototypes for local procedures defined in this file:
  50.  */
  52. static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
  53.     Tcl_Obj *copyPtr));
  54. static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
  55.     Tcl_Obj *src, unsigned char **cursorPtr));
  56. static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,
  57.     unsigned int length));
  58. static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
  59. static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
  60.     char *cmdPtr, int *countPtr));
  61. static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
  62.     int type, Tcl_HashTable **numberCachePtr));
  63. static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
  64.     Tcl_Obj *objPtr));
  65. static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
  66. static void DeleteScanNumberCache _ANSI_ARGS_((
  67.     Tcl_HashTable *numberCachePtr));
  69. /*
  70.  * The following object type represents an array of bytes.  An array of
  71.  * bytes is not equivalent to an internationalized string.  Conceptually, a
  72.  * string is an array of 16-bit quantities organized as a sequence of properly
  73.  * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
  74.  * Accessor functions are provided to convert a ByteArray to a String or a
  75.  * String to a ByteArray.  Two or more consecutive bytes in an array of bytes
  76.  * may look like a single UTF-8 character if the array is casually treated as
  77.  * a string.  But obtaining the String from a ByteArray is guaranteed to
  78.  * produced properly formed UTF-8 sequences so that there is a one-to-one
  79.  * map between bytes and characters.
  80.  *
  81.  * Converting a ByteArray to a String proceeds by casting each byte in the
  82.  * array to a 16-bit quantity, treating that number as a Unicode character,
  83.  * and storing the UTF-8 version of that Unicode character in the String.
  84.  * For ByteArrays consisting entirely of values 1..127, the corresponding
  85.  * String representation is the same as the ByteArray representation.
  86.  *
  87.  * Converting a String to a ByteArray proceeds by getting the Unicode
  88.  * representation of each character in the String, casting it to a
  89.  * byte by truncating the upper 8 bits, and then storing the byte in the
  90.  * ByteArray.  Converting from ByteArray to String and back to ByteArray
  91.  * is not lossy, but converting an arbitrary String to a ByteArray may be.
  92.  */
  94. Tcl_ObjType tclByteArrayType = {
  95.     "bytearray",
  96.     FreeByteArrayInternalRep,
  97.     DupByteArrayInternalRep,
  98.     UpdateStringOfByteArray,
  99.     SetByteArrayFromAny
  100. };
  102. /*
  103.  * The following structure is the internal rep for a ByteArray object.
  104.  * Keeps track of how much memory has been used and how much has been
  105.  * allocated for the byte array to enable growing and shrinking of the
  106.  * ByteArray object with fewer mallocs.  
  107.  */
  109. typedef struct ByteArray {
  110.     int used; /* The number of bytes used in the byte
  111.  * array. */
  112.     int allocated; /* The amount of space actually allocated
  113.  * minus 1 byte. */
  114.     unsigned char bytes[4]; /* The array of bytes.  The actual size of
  115.  * this field depends on the 'allocated' field
  116.  * above. */
  117. } ByteArray;
  119. #define BYTEARRAY_SIZE(len)
  120. ((unsigned) (sizeof(ByteArray) - 4 + (len)))
  121. #define GET_BYTEARRAY(objPtr) 
  122. ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
  123. #define SET_BYTEARRAY(objPtr, baPtr) 
  124. (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
  127. /*
  128.  *---------------------------------------------------------------------------
  129.  *
  130.  * Tcl_NewByteArrayObj --
  131.  *
  132.  * This procedure is creates a new ByteArray object and initializes
  133.  * it from the given array of bytes.
  134.  *
  135.  * Results:
  136.  * The newly create object is returned.  This object will have no
  137.  * initial string representation.  The returned object has a ref count
  138.  * of 0.
  139.  *
  140.  * Side effects:
  141.  * Memory allocated for new object and copy of byte array argument.
  142.  *
  143.  *---------------------------------------------------------------------------
  144.  */
  146. #ifdef TCL_MEM_DEBUG
  147. #undef Tcl_NewByteArrayObj
  150. Tcl_Obj *
  151. Tcl_NewByteArrayObj(bytes, length)
  152.     CONST unsigned char *bytes; /* The array of bytes used to initialize
  153.  * the new object. */
  154.     int length; /* Length of the array of bytes, which must
  155.  * be >= 0. */
  156. {
  157.     return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
  158. }
  160. #else /* if not TCL_MEM_DEBUG */
  162. Tcl_Obj *
  163. Tcl_NewByteArrayObj(bytes, length)
  164.     CONST unsigned char *bytes; /* The array of bytes used to initialize
  165.  * the new object. */
  166.     int length; /* Length of the array of bytes, which must
  167.  * be >= 0. */
  168. {
  169.     Tcl_Obj *objPtr;
  171.     TclNewObj(objPtr);
  172.     Tcl_SetByteArrayObj(objPtr, bytes, length);
  173.     return objPtr;
  174. }
  175. #endif /* TCL_MEM_DEBUG */
  177. /*
  178.  *---------------------------------------------------------------------------
  179.  *
  180.  * Tcl_DbNewByteArrayObj --
  181.  *
  182.  * This procedure is normally called when debugging: i.e., when
  183.  * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
  184.  * above except that it calls Tcl_DbCkalloc directly with the file name
  185.  * and line number from its caller. This simplifies debugging since then
  186.  * the [memory active] command will report the correct file name and line
  187.  * number when reporting objects that haven't been freed.
  188.  *
  189.  * When TCL_MEM_DEBUG is not defined, this procedure just returns the
  190.  * result of calling Tcl_NewByteArrayObj.
  191.  *
  192.  * Results:
  193.  * The newly create object is returned.  This object will have no
  194.  * initial string representation.  The returned object has a ref count
  195.  * of 0.
  196.  *
  197.  * Side effects:
  198.  * Memory allocated for new object and copy of byte array argument.
  199.  *
  200.  *---------------------------------------------------------------------------
  201.  */
  203. #ifdef TCL_MEM_DEBUG
  205. Tcl_Obj *
  206. Tcl_DbNewByteArrayObj(bytes, length, file, line)
  207.     CONST unsigned char *bytes; /* The array of bytes used to initialize
  208.  * the new object. */
  209.     int length; /* Length of the array of bytes, which must
  210.  * be >= 0. */
  211.     CONST char *file; /* The name of the source file calling this
  212.  * procedure; used for debugging. */
  213.     int line; /* Line number in the source file; used
  214.  * for debugging. */
  215. {
  216.     Tcl_Obj *objPtr;
  218.     TclDbNewObj(objPtr, file, line);
  219.     Tcl_SetByteArrayObj(objPtr, bytes, length);
  220.     return objPtr;
  221. }
  223. #else /* if not TCL_MEM_DEBUG */
  225. Tcl_Obj *
  226. Tcl_DbNewByteArrayObj(bytes, length, file, line)
  227.     CONST unsigned char *bytes; /* The array of bytes used to initialize
  228.  * the new object. */
  229.     int length; /* Length of the array of bytes, which must
  230.  * be >= 0. */
  231.     CONST char *file; /* The name of the source file calling this
  232.  * procedure; used for debugging. */
  233.     int line; /* Line number in the source file; used
  234.  * for debugging. */
  235. {
  236.     return Tcl_NewByteArrayObj(bytes, length);
  237. }
  238. #endif /* TCL_MEM_DEBUG */
  240. /*
  241.  *---------------------------------------------------------------------------
  242.  *
  243.  * Tcl_SetByteArrayObj --
  244.  *
  245.  * Modify an object to be a ByteArray object and to have the specified
  246.  * array of bytes as its value.
  247.  *
  248.  * Results:
  249.  * None.
  250.  *
  251.  * Side effects:
  252.  * The object's old string rep and internal rep is freed.
  253.  * Memory allocated for copy of byte array argument.
  254.  *
  255.  *----------------------------------------------------------------------
  256.  */
  258. void
  259. Tcl_SetByteArrayObj(objPtr, bytes, length)
  260.     Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */
  261.     CONST unsigned char *bytes; /* The array of bytes to use as the new
  262.  * value. */
  263.     int length; /* Length of the array of bytes, which must
  264.  * be >= 0. */
  265. {
  266.     Tcl_ObjType *typePtr;
  267.     ByteArray *byteArrayPtr;
  269.     if (Tcl_IsShared(objPtr)) {
  270. panic("Tcl_SetByteArrayObj called with shared object");
  271.     }
  272.     typePtr = objPtr->typePtr;
  273.     if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
  274. (*typePtr->freeIntRepProc)(objPtr);
  275.     }
  276.     Tcl_InvalidateStringRep(objPtr);
  278.     byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  279.     byteArrayPtr->used = length;
  280.     byteArrayPtr->allocated = length;
  281.     memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length);
  283.     objPtr->typePtr = &tclByteArrayType;
  284.     SET_BYTEARRAY(objPtr, byteArrayPtr);
  285. }
  287. /*
  288.  *----------------------------------------------------------------------
  289.  *
  290.  * Tcl_GetByteArrayFromObj --
  291.  *
  292.  * Attempt to get the array of bytes from the Tcl object.  If the
  293.  * object is not already a ByteArray object, an attempt will be
  294.  * made to convert it to one.
  295.  *
  296.  * Results:
  297.  * Pointer to array of bytes representing the ByteArray object.
  298.  *
  299.  * Side effects:
  300.  * Frees old internal rep.  Allocates memory for new internal rep.
  301.  *
  302.  *----------------------------------------------------------------------
  303.  */
  305. unsigned char *
  306. Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
  307.     Tcl_Obj *objPtr; /* The ByteArray object. */
  308.     int *lengthPtr; /* If non-NULL, filled with length of the
  309.  * array of bytes in the ByteArray object. */
  310. {
  311.     ByteArray *baPtr;
  312.     
  313.     SetByteArrayFromAny(NULL, objPtr);
  314.     baPtr = GET_BYTEARRAY(objPtr);
  316.     if (lengthPtr != NULL) {
  317. *lengthPtr = baPtr->used;
  318.     }
  319.     return (unsigned char *) baPtr->bytes;
  320. }
  322. /*
  323.  *----------------------------------------------------------------------
  324.  *
  325.  * Tcl_SetByteArrayLength --
  326.  *
  327.  * This procedure changes the length of the byte array for this
  328.  * object.  Once the caller has set the length of the array, it
  329.  * is acceptable to directly modify the bytes in the array up until
  330.  * Tcl_GetStringFromObj() has been called on this object.
  331.  *
  332.  * Results:
  333.  * The new byte array of the specified length.
  334.  *
  335.  * Side effects:
  336.  * Allocates enough memory for an array of bytes of the requested
  337.  * size.  When growing the array, the old array is copied to the
  338.  * new array; new bytes are undefined.  When shrinking, the
  339.  * old array is truncated to the specified length.
  340.  *
  341.  *---------------------------------------------------------------------------
  342.  */
  344. unsigned char *
  345. Tcl_SetByteArrayLength(objPtr, length)
  346.     Tcl_Obj *objPtr; /* The ByteArray object. */
  347.     int length; /* New length for internal byte array. */
  348. {
  349.     ByteArray *byteArrayPtr, *newByteArrayPtr;
  350.     
  351.     if (Tcl_IsShared(objPtr)) {
  352. panic("Tcl_SetObjLength called with shared object");
  353.     }
  354.     if (objPtr->typePtr != &tclByteArrayType) {
  355. SetByteArrayFromAny(NULL, objPtr);
  356.     }
  358.     byteArrayPtr = GET_BYTEARRAY(objPtr);
  359.     if (length > byteArrayPtr->allocated) {
  360. newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  361. newByteArrayPtr->used = length;
  362. newByteArrayPtr->allocated = length;
  363. memcpy((VOID *) newByteArrayPtr->bytes,
  364. (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);
  365. ckfree((char *) byteArrayPtr);
  366. byteArrayPtr = newByteArrayPtr;
  367. SET_BYTEARRAY(objPtr, byteArrayPtr);
  368.     }
  369.     Tcl_InvalidateStringRep(objPtr);
  370.     byteArrayPtr->used = length;
  371.     return byteArrayPtr->bytes;
  372. }
  374. /*
  375.  *---------------------------------------------------------------------------
  376.  *
  377.  * SetByteArrayFromAny --
  378.  *
  379.  * Generate the ByteArray internal rep from the string rep.
  380.  *
  381.  * Results:
  382.  * The return value is always TCL_OK.
  383.  *
  384.  * Side effects:
  385.  * A ByteArray object is stored as the internal rep of objPtr.
  386.  *
  387.  *---------------------------------------------------------------------------
  388.  */
  390. static int
  391. SetByteArrayFromAny(interp, objPtr)
  392.     Tcl_Interp *interp; /* Not used. */
  393.     Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */
  394. {
  395.     Tcl_ObjType *typePtr;
  396.     int length;
  397.     char *src, *srcEnd;
  398.     unsigned char *dst;
  399.     ByteArray *byteArrayPtr;
  400.     Tcl_UniChar ch;
  401.     
  402.     typePtr = objPtr->typePtr;
  403.     if (typePtr != &tclByteArrayType) {
  404. src = Tcl_GetStringFromObj(objPtr, &length);
  405. srcEnd = src + length;
  407. byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  408. for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
  409.     src += Tcl_UtfToUniChar(src, &ch);
  410.     *dst++ = (unsigned char) ch;
  411. }
  413. byteArrayPtr->used = dst - byteArrayPtr->bytes;
  414. byteArrayPtr->allocated = length;
  416. if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
  417.     (*typePtr->freeIntRepProc)(objPtr);
  418. }
  419. objPtr->typePtr = &tclByteArrayType;
  420. SET_BYTEARRAY(objPtr, byteArrayPtr);
  421.     }
  422.     return TCL_OK;
  423. }
  425. /*
  426.  *----------------------------------------------------------------------
  427.  *
  428.  * FreeByteArrayInternalRep --
  429.  *
  430.  * Deallocate the storage associated with a ByteArray data object's
  431.  * internal representation.
  432.  *
  433.  * Results:
  434.  * None.
  435.  *
  436.  * Side effects:
  437.  * Frees memory. 
  438.  *
  439.  *----------------------------------------------------------------------
  440.  */
  442. static void
  443. FreeByteArrayInternalRep(objPtr)
  444.     Tcl_Obj *objPtr; /* Object with internal rep to free. */
  445. {
  446.     ckfree((char *) GET_BYTEARRAY(objPtr));
  447. }
  449. /*
  450.  *---------------------------------------------------------------------------
  451.  *
  452.  * DupByteArrayInternalRep --
  453.  *
  454.  * Initialize the internal representation of a ByteArray Tcl_Obj
  455.  * to a copy of the internal representation of an existing ByteArray
  456.  * object. 
  457.  *
  458.  * Results:
  459.  * None.
  460.  *
  461.  * Side effects:
  462.  * Allocates memory.
  463.  *
  464.  *---------------------------------------------------------------------------
  465.  */
  467. static void
  468. DupByteArrayInternalRep(srcPtr, copyPtr)
  469.     Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
  470.     Tcl_Obj *copyPtr; /* Object with internal rep to set. */
  471. {
  472.     int length;
  473.     ByteArray *srcArrayPtr, *copyArrayPtr;    
  475.     srcArrayPtr = GET_BYTEARRAY(srcPtr);
  476.     length = srcArrayPtr->used;
  478.     copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
  479.     copyArrayPtr->used = length;
  480.     copyArrayPtr->allocated = length;
  481.     memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
  482.     (size_t) length);
  483.     SET_BYTEARRAY(copyPtr, copyArrayPtr);
  485.     copyPtr->typePtr = &tclByteArrayType;
  486. }
  488. /*
  489.  *---------------------------------------------------------------------------
  490.  *
  491.  * UpdateStringOfByteArray --
  492.  *
  493.  * Update the string representation for a ByteArray data object.
  494.  * Note: This procedure does not invalidate an existing old string rep
  495.  * so storage will be lost if this has not already been done. 
  496.  *
  497.  * Results:
  498.  * None.
  499.  *
  500.  * Side effects:
  501.  * The object's string is set to a valid string that results from
  502.  * the ByteArray-to-string conversion.
  503.  *
  504.  * The object becomes a string object -- the internal rep is
  505.  * discarded and the typePtr becomes NULL.
  506.  *
  507.  *---------------------------------------------------------------------------
  508.  */
  510. static void
  511. UpdateStringOfByteArray(objPtr)
  512.     Tcl_Obj *objPtr; /* ByteArray object whose string rep to
  513.  * update. */
  514. {
  515.     int i, length, size;
  516.     unsigned char *src;
  517.     char *dst;
  518.     ByteArray *byteArrayPtr;
  520.     byteArrayPtr = GET_BYTEARRAY(objPtr);
  521.     src = byteArrayPtr->bytes;
  522.     length = byteArrayPtr->used;
  524.     /*
  525.      * How much space will string rep need?
  526.      */
  527.      
  528.     size = length;
  529.     for (i = 0; i < length; i++) {
  530. if ((src[i] == 0) || (src[i] > 127)) {
  531.     size++;
  532. }
  533.     }
  535.     dst = (char *) ckalloc((unsigned) (size + 1));
  536.     objPtr->bytes = dst;
  537.     objPtr->length = size;
  539.     if (size == length) {
  540. memcpy((VOID *) dst, (VOID *) src, (size_t) size);
  541. dst[size] = '';
  542.     } else {
  543. for (i = 0; i < length; i++) {
  544.     dst += Tcl_UniCharToUtf(src[i], dst);
  545. }
  546. *dst = '';
  547.     }
  548. }
  550. /*
  551.  *----------------------------------------------------------------------
  552.  *
  553.  * Tcl_BinaryObjCmd --
  554.  *
  555.  * This procedure implements the "binary" Tcl command.
  556.  *
  557.  * Results:
  558.  * A standard Tcl result.
  559.  *
  560.  * Side effects:
  561.  * See the user documentation.
  562.  *
  563.  *----------------------------------------------------------------------
  564.  */
  566. int
  567. Tcl_BinaryObjCmd(dummy, interp, objc, objv)
  568.     ClientData dummy; /* Not used. */
  569.     Tcl_Interp *interp; /* Current interpreter. */
  570.     int objc; /* Number of arguments. */
  571.     Tcl_Obj *CONST objv[]; /* Argument objects. */
  572. {
  573.     int arg; /* Index of next argument to consume. */
  574.     int value = 0; /* Current integer value to be packed.
  575.  * Initialized to avoid compiler warning. */
  576.     char cmd; /* Current format character. */
  577.     int count; /* Count associated with current format
  578.  * character. */
  579.     char *format; /* Pointer to current position in format
  580.  * string. */
  581.     Tcl_Obj *resultPtr; /* Object holding result buffer. */
  582.     unsigned char *buffer; /* Start of result buffer. */
  583.     unsigned char *cursor; /* Current position within result buffer. */
  584.     unsigned char *maxPos; /* Greatest position within result buffer that
  585.  * cursor has visited.*/
  586.     char *errorString, *errorValue, *str;
  587.     int offset, size, length, index;
  588.     static CONST char *options[] = { 
  589. "format", "scan", NULL 
  590.     };
  591.     enum options { 
  592. BINARY_FORMAT, BINARY_SCAN
  593.     };
  595.     if (objc < 2) {
  596.      Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
  597. return TCL_ERROR;
  598.     }
  600.     if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
  601.     &index) != TCL_OK) {
  602.      return TCL_ERROR;
  603.     }
  605.     switch ((enum options) index) {
  606. case BINARY_FORMAT: {
  607.     if (objc < 3) {
  608. Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
  609. return TCL_ERROR;
  610.     }
  612.     /*
  613.      * To avoid copying the data, we format the string in two passes.
  614.      * The first pass computes the size of the output buffer.  The
  615.      * second pass places the formatted data into the buffer.
  616.      */
  618.     format = Tcl_GetString(objv[2]);
  619.     arg = 3;
  620.     offset = 0;
  621.     length = 0;
  622.     while (*format != '') {
  623. str = format;
  624. if (!GetFormatSpec(&format, &cmd, &count)) {
  625.     break;
  626. }
  627. switch (cmd) {
  628.     case 'a':
  629.     case 'A':
  630.     case 'b':
  631.     case 'B':
  632.     case 'h':
  633.     case 'H': {
  634. /*
  635.  * For string-type specifiers, the count corresponds
  636.  * to the number of bytes in a single argument.
  637.  */
  639. if (arg >= objc) {
  640.     goto badIndex;
  641. }
  642. if (count == BINARY_ALL) {
  643.     Tcl_GetByteArrayFromObj(objv[arg], &count);
  644. } else if (count == BINARY_NOCOUNT) {
  645.     count = 1;
  646. }
  647. arg++;
  648. if (cmd == 'a' || cmd == 'A') {
  649.     offset += count;
  650. } else if (cmd == 'b' || cmd == 'B') {
  651.     offset += (count + 7) / 8;
  652. } else {
  653.     offset += (count + 1) / 2;
  654. }
  655. break;
  656.     }
  657.     case 'c': {
  658. size = 1;
  659. goto doNumbers;
  660.     }
  661.     case 's':
  662.     case 'S': {
  663. size = 2;
  664. goto doNumbers;
  665.     }
  666.     case 'i':
  667.     case 'I': {
  668. size = 4;
  669. goto doNumbers;
  670.     }
  671.     case 'w':
  672.     case 'W': {
  673. size = 8;
  674. goto doNumbers;
  675.     }
  676.     case 'f': {
  677. size = sizeof(float);
  678. goto doNumbers;
  679.     }
  680.     case 'd': {
  681. size = sizeof(double);
  683. doNumbers:
  684. if (arg >= objc) {
  685.     goto badIndex;
  686. }
  688. /*
  689.  * For number-type specifiers, the count corresponds
  690.  * to the number of elements in the list stored in
  691.  * a single argument.  If no count is specified, then
  692.  * the argument is taken as a single non-list value.
  693.  */
  695. if (count == BINARY_NOCOUNT) {
  696.     arg++;
  697.     count = 1;
  698. } else {
  699.     int listc;
  700.     Tcl_Obj **listv;
  701.     if (Tcl_ListObjGetElements(interp, objv[arg++],
  702.     &listc, &listv) != TCL_OK) {
  703. return TCL_ERROR;
  704.     }
  705.     if (count == BINARY_ALL) {
  706. count = listc;
  707.     } else if (count > listc) {
  708.         Tcl_AppendResult(interp, 
  709. "number of elements in list does not match count",
  710. (char *) NULL);
  711. return TCL_ERROR;
  712.     }
  713. }
  714. offset += count*size;
  715. break;
  716.     }
  717.     case 'x': {
  718. if (count == BINARY_ALL) {
  719.     Tcl_AppendResult(interp, 
  720.     "cannot use "*" in format string with "x"",
  721.     (char *) NULL);
  722.     return TCL_ERROR;
  723. } else if (count == BINARY_NOCOUNT) {
  724.     count = 1;
  725. }
  726. offset += count;
  727. break;
  728.     }
  729.     case 'X': {
  730. if (count == BINARY_NOCOUNT) {
  731.     count = 1;
  732. }
  733. if ((count > offset) || (count == BINARY_ALL)) {
  734.     count = offset;
  735. }
  736. if (offset > length) {
  737.     length = offset;
  738. }
  739. offset -= count;
  740. break;
  741.     }
  742.     case '@': {
  743. if (offset > length) {
  744.     length = offset;
  745. }
  746. if (count == BINARY_ALL) {
  747.     offset = length;
  748. } else if (count == BINARY_NOCOUNT) {
  749.     goto badCount;
  750. } else {
  751.     offset = count;
  752. }
  753. break;
  754.     }
  755.     default: {
  756. errorString = str;
  757. goto badField;
  758.     }
  759. }
  760.     }
  761.     if (offset > length) {
  762. length = offset;
  763.     }
  764.     if (length == 0) {
  765. return TCL_OK;
  766.     }
  768.     /*
  769.      * Prepare the result object by preallocating the caclulated
  770.      * number of bytes and filling with nulls.
  771.      */
  773.     resultPtr = Tcl_GetObjResult(interp);
  774.     if (Tcl_IsShared(resultPtr)) {
  775. TclNewObj(resultPtr);
  776. Tcl_SetObjResult(interp, resultPtr);
  777.     }
  778.     buffer = Tcl_SetByteArrayLength(resultPtr, length);
  779.     memset((VOID *) buffer, 0, (size_t) length);
  781.     /*
  782.      * Pack the data into the result object.  Note that we can skip
  783.      * the error checking during this pass, since we have already
  784.      * parsed the string once.
  785.      */
  787.     arg = 3;
  788.     format = Tcl_GetString(objv[2]);
  789.     cursor = buffer;
  790.     maxPos = cursor;
  791.     while (*format != 0) {
  792. if (!GetFormatSpec(&format, &cmd, &count)) {
  793.     break;
  794. }
  795. if ((count == 0) && (cmd != '@')) {
  796.     arg++;
  797.     continue;
  798. }
  799. switch (cmd) {
  800.     case 'a':
  801.     case 'A': {
  802. char pad = (char) (cmd == 'a' ? '' : ' ');
  803. unsigned char *bytes;
  805. bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
  807. if (count == BINARY_ALL) {
  808.     count = length;
  809. } else if (count == BINARY_NOCOUNT) {
  810.     count = 1;
  811. }
  812. if (length >= count) {
  813.     memcpy((VOID *) cursor, (VOID *) bytes,
  814.     (size_t) count);
  815. } else {
  816.     memcpy((VOID *) cursor, (VOID *) bytes,
  817.     (size_t) length);
  818.     memset((VOID *) (cursor + length), pad,
  819.             (size_t) (count - length));
  820. }
  821. cursor += count;
  822. break;
  823.     }
  824.     case 'b':
  825.     case 'B': {
  826. unsigned char *last;
  828. str = Tcl_GetStringFromObj(objv[arg++], &length);
  829. if (count == BINARY_ALL) {
  830.     count = length;
  831. } else if (count == BINARY_NOCOUNT) {
  832.     count = 1;
  833. }
  834. last = cursor + ((count + 7) / 8);
  835. if (count > length) {
  836.     count = length;
  837. }
  838. value = 0;
  839. errorString = "binary";
  840. if (cmd == 'B') {
  841.     for (offset = 0; offset < count; offset++) {
  842. value <<= 1;
  843. if (str[offset] == '1') {
  844.     value |= 1;
  845. } else if (str[offset] != '0') {
  846.     errorValue = str;
  847.     goto badValue;
  848. }
  849. if (((offset + 1) % 8) == 0) {
  850.     *cursor++ = (unsigned char) value;
  851.     value = 0;
  852. }
  853.     }
  854. } else {
  855.     for (offset = 0; offset < count; offset++) {
  856. value >>= 1;
  857. if (str[offset] == '1') {
  858.     value |= 128;
  859. } else if (str[offset] != '0') {
  860.     errorValue = str;
  861.     goto badValue;
  862. }
  863. if (!((offset + 1) % 8)) {
  864.     *cursor++ = (unsigned char) value;
  865.     value = 0;
  866. }
  867.     }
  868. }
  869. if ((offset % 8) != 0) {
  870.     if (cmd == 'B') {
  871. value <<= 8 - (offset % 8);
  872.     } else {
  873. value >>= 8 - (offset % 8);
  874.     }
  875.     *cursor++ = (unsigned char) value;
  876. }
  877. while (cursor < last) {
  878.     *cursor++ = '';
  879. }
  880. break;
  881.     }
  882.     case 'h':
  883.     case 'H': {
  884. unsigned char *last;
  885. int c;
  887. str = Tcl_GetStringFromObj(objv[arg++], &length);
  888. if (count == BINARY_ALL) {
  889.     count = length;
  890. } else if (count == BINARY_NOCOUNT) {
  891.     count = 1;
  892. }
  893. last = cursor + ((count + 1) / 2);
  894. if (count > length) {
  895.     count = length;
  896. }
  897. value = 0;
  898. errorString = "hexadecimal";
  899. if (cmd == 'H') {
  900.     for (offset = 0; offset < count; offset++) {
  901. value <<= 4;
  902. if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
  903.     errorValue = str;
  904.     goto badValue;
  905. }
  906. c = str[offset] - '0';
  907. if (c > 9) {
  908.     c += ('0' - 'A') + 10;
  909. }
  910. if (c > 16) {
  911.     c += ('A' - 'a');
  912. }
  913. value |= (c & 0xf);
  914. if (offset % 2) {
  915.     *cursor++ = (char) value;
  916.     value = 0;
  917. }
  918.     }
  919. } else {
  920.     for (offset = 0; offset < count; offset++) {
  921. value >>= 4;
  923. if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
  924.     errorValue = str;
  925.     goto badValue;
  926. }
  927. c = str[offset] - '0';
  928. if (c > 9) {
  929.     c += ('0' - 'A') + 10;
  930. }
  931. if (c > 16) {
  932.     c += ('A' - 'a');
  933. }
  934. value |= ((c << 4) & 0xf0);
  935. if (offset % 2) {
  936.     *cursor++ = (unsigned char)(value & 0xff);
  937.     value = 0;
  938. }
  939.     }
  940. }
  941. if (offset % 2) {
  942.     if (cmd == 'H') {
  943. value <<= 4;
  944.     } else {
  945. value >>= 4;
  946.     }
  947.     *cursor++ = (unsigned char) value;
  948. }
  950. while (cursor < last) {
  951.     *cursor++ = '';
  952. }
  953. break;
  954.     }
  955.     case 'c':
  956.     case 's':
  957.     case 'S':
  958.     case 'i':
  959.     case 'I':
  960.     case 'w':
  961.     case 'W':
  962.     case 'd':
  963.     case 'f': {
  964. int listc, i;
  965. Tcl_Obj **listv;
  967. if (count == BINARY_NOCOUNT) {
  968.     /*
  969.      * Note that we are casting away the const-ness of
  970.      * objv, but this is safe since we aren't going to
  971.      * modify the array.
  972.      */
  974.     listv = (Tcl_Obj**)(objv + arg);
  975.     listc = 1;
  976.     count = 1;
  977. } else {
  978.     Tcl_ListObjGetElements(interp, objv[arg],
  979.     &listc, &listv);
  980.     if (count == BINARY_ALL) {
  981. count = listc;
  982.     }
  983. }
  984. arg++;
  985. for (i = 0; i < count; i++) {
  986.     if (FormatNumber(interp, cmd, listv[i], &cursor)
  987.     != TCL_OK) {
  988. return TCL_ERROR;
  989.     }
  990. }
  991. break;
  992.     }
  993.     case 'x': {
  994. if (count == BINARY_NOCOUNT) {
  995.     count = 1;
  996. }
  997. memset(cursor, 0, (size_t) count);
  998. cursor += count;
  999. break;
  1000.     }
  1001.     case 'X': {
  1002. if (cursor > maxPos) {
  1003.     maxPos = cursor;
  1004. }
  1005. if (count == BINARY_NOCOUNT) {
  1006.     count = 1;
  1007. }
  1008. if ((count == BINARY_ALL)
  1009. || (count > (cursor - buffer))) {
  1010.     cursor = buffer;
  1011. } else {
  1012.     cursor -= count;
  1013. }
  1014. break;
  1015.     }
  1016.     case '@': {
  1017. if (cursor > maxPos) {
  1018.     maxPos = cursor;
  1019. }
  1020. if (count == BINARY_ALL) {
  1021.     cursor = maxPos;
  1022. } else {
  1023.     cursor = buffer + count;
  1024. }
  1025. break;
  1026.     }
  1027. }
  1028.     }
  1029.     break;
  1030. }
  1031. case BINARY_SCAN: {
  1032.     int i;
  1033.     Tcl_Obj *valuePtr, *elementPtr;
  1034.     Tcl_HashTable numberCacheHash;
  1035.     Tcl_HashTable *numberCachePtr;
  1037.     if (objc < 4) {
  1038. Tcl_WrongNumArgs(interp, 2, objv,
  1039. "value formatString ?varName varName ...?");
  1040. return TCL_ERROR;
  1041.     }
  1042.     numberCachePtr = &numberCacheHash;
  1043.     Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
  1044.     buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
  1045.     format = Tcl_GetString(objv[3]);
  1046.     cursor = buffer;
  1047.     arg = 4;
  1048.     offset = 0;
  1049.     while (*format != '') {
  1050. str = format;
  1051. if (!GetFormatSpec(&format, &cmd, &count)) {
  1052.     goto done;
  1053. }
  1054. switch (cmd) {
  1055.     case 'a':
  1056.     case 'A': {
  1057. unsigned char *src;
  1059. if (arg >= objc) {
  1060.     DeleteScanNumberCache(numberCachePtr);
  1061.     goto badIndex;
  1062. }
  1063. if (count == BINARY_ALL) {
  1064.     count = length - offset;
  1065. } else {
  1066.     if (count == BINARY_NOCOUNT) {
  1067. count = 1;
  1068.     }
  1069.     if (count > (length - offset)) {
  1070. goto done;
  1071.     }
  1072. }
  1074. src = buffer + offset;
  1075. size = count;
  1077. /*
  1078.  * Trim trailing nulls and spaces, if necessary.
  1079.  */
  1081. if (cmd == 'A') {
  1082.     while (size > 0) {
  1083. if (src[size-1] != '' && src[size-1] != ' ') {
  1084.     break;
  1085. }
  1086. size--;
  1087.     }
  1088. }
  1089. valuePtr = Tcl_NewByteArrayObj(src, size);
  1090. Tcl_IncrRefCount(valuePtr);
  1091. resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
  1092. NULL, valuePtr, TCL_LEAVE_ERR_MSG);
  1093. Tcl_DecrRefCount(valuePtr);
  1094. arg++;
  1095. if (resultPtr == NULL) {
  1096.     DeleteScanNumberCache(numberCachePtr);
  1097.     return TCL_ERROR;
  1098. }
  1099. offset += count;
  1100. break;
  1101.     }
  1102.     case 'b':
  1103.     case 'B': {
  1104. unsigned char *src;
  1105. char *dest;
  1107. if (arg >= objc) {
  1108.     DeleteScanNumberCache(numberCachePtr);
  1109.     goto badIndex;
  1110. }
  1111. if (count == BINARY_ALL) {
  1112.     count = (length - offset) * 8;
  1113. } else {
  1114.     if (count == BINARY_NOCOUNT) {
  1115. count = 1;
  1116.     }
  1117.     if (count > (length - offset) * 8) {
  1118. goto done;
  1119.     }
  1120. }
  1121. src = buffer + offset;
  1122. valuePtr = Tcl_NewObj();
  1123. Tcl_SetObjLength(valuePtr, count);
  1124. dest = Tcl_GetString(valuePtr);
  1126. if (cmd == 'b') {
  1127.     for (i = 0; i < count; i++) {
  1128. if (i % 8) {
  1129.     value >>= 1;
  1130. } else {
  1131.     value = *src++;
  1132. }
  1133. *dest++ = (char) ((value & 1) ? '1' : '0');
  1134.     }
  1135. } else {
  1136.     for (i = 0; i < count; i++) {
  1137. if (i % 8) {
  1138.     value <<= 1;
  1139. } else {
  1140.     value = *src++;
  1141. }
  1142. *dest++ = (char) ((value & 0x80) ? '1' : '0');
  1143.     }
  1144. }
  1146. Tcl_IncrRefCount(valuePtr);
  1147. resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
  1148. NULL, valuePtr, TCL_LEAVE_ERR_MSG);
  1149. Tcl_DecrRefCount(valuePtr);
  1150. arg++;
  1151. if (resultPtr == NULL) {
  1152.     DeleteScanNumberCache(numberCachePtr);
  1153.     return TCL_ERROR;
  1154. }
  1155. offset += (count + 7 ) / 8;
  1156. break;
  1157.     }
  1158.     case 'h':
  1159.     case 'H': {
  1160. char *dest;
  1161. unsigned char *src;
  1162. int i;
  1163. static char hexdigit[] = "0123456789abcdef";
  1165. if (arg >= objc) {
  1166.     DeleteScanNumberCache(numberCachePtr);
  1167.     goto badIndex;
  1168. }
  1169. if (count == BINARY_ALL) {
  1170.     count = (length - offset)*2;
  1171. } else {
  1172.     if (count == BINARY_NOCOUNT) {
  1173. count = 1;
  1174.     }
  1175.     if (count > (length - offset)*2) {
  1176. goto done;
  1177.     }
  1178. }
  1179. src = buffer + offset;
  1180. valuePtr = Tcl_NewObj();
  1181. Tcl_SetObjLength(valuePtr, count);
  1182. dest = Tcl_GetString(valuePtr);
  1184. if (cmd == 'h') {
  1185.     for (i = 0; i < count; i++) {
  1186. if (i % 2) {
  1187.     value >>= 4;
  1188. } else {
  1189.     value = *src++;
  1190. }
  1191. *dest++ = hexdigit[value & 0xf];
  1192.     }
  1193. } else {
  1194.     for (i = 0; i < count; i++) {
  1195. if (i % 2) {
  1196.     value <<= 4;
  1197. } else {
  1198.     value = *src++;
  1199. }
  1200. *dest++ = hexdigit[(value >> 4) & 0xf];
  1201.     }
  1202. }
  1204. Tcl_IncrRefCount(valuePtr);
  1205. resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
  1206. NULL, valuePtr, TCL_LEAVE_ERR_MSG);
  1207. Tcl_DecrRefCount(valuePtr);
  1208. arg++;
  1209. if (resultPtr == NULL) {
  1210.     DeleteScanNumberCache(numberCachePtr);
  1211.     return TCL_ERROR;
  1212. }
  1213. offset += (count + 1) / 2;
  1214. break;
  1215.     }
  1216.     case 'c': {
  1217. size = 1;
  1218. goto scanNumber;
  1219.     }
  1220.     case 's':
  1221.     case 'S': {
  1222. size = 2;
  1223. goto scanNumber;
  1224.     }
  1225.     case 'i':
  1226.     case 'I': {
  1227. size = 4;
  1228. goto scanNumber;
  1229.     }
  1230.     case 'w':
  1231.     case 'W': {
  1232. size = 8;
  1233. goto scanNumber;
  1234.     }
  1235.     case 'f': {
  1236. size = sizeof(float);
  1237. goto scanNumber;
  1238.     }
  1239.     case 'd': {
  1240. unsigned char *src;
  1242. size = sizeof(double);
  1243. /* fall through */
  1245. scanNumber:
  1246. if (arg >= objc) {
  1247.     DeleteScanNumberCache(numberCachePtr);
  1248.     goto badIndex;
  1249. }
  1250. if (count == BINARY_NOCOUNT) {
  1251.     if ((length - offset) < size) {
  1252. goto done;
  1253.     }
  1254.     valuePtr = ScanNumber(buffer+offset, cmd,
  1255.     &numberCachePtr);
  1256.     offset += size;
  1257. } else {
  1258.     if (count == BINARY_ALL) {
  1259. count = (length - offset) / size;
  1260.     }
  1261.     if ((length - offset) < (count * size)) {
  1262. goto done;
  1263.     }
  1264.     valuePtr = Tcl_NewObj();
  1265.     src = buffer+offset;
  1266.     for (i = 0; i < count; i++) {
  1267. elementPtr = ScanNumber(src, cmd,
  1268. &numberCachePtr);
  1269. src += size;
  1270. Tcl_ListObjAppendElement(NULL, valuePtr,
  1271. elementPtr);
  1272.     }
  1273.     offset += count*size;
  1274. }
  1276. Tcl_IncrRefCount(valuePtr); 
  1277. resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
  1278. NULL, valuePtr, TCL_LEAVE_ERR_MSG);
  1279. Tcl_DecrRefCount(valuePtr);
  1280. arg++;
  1281. if (resultPtr == NULL) {
  1282.     DeleteScanNumberCache(numberCachePtr);
  1283.     return TCL_ERROR;
  1284. }
  1285. break;
  1286.     }
  1287.     case 'x': {
  1288. if (count == BINARY_NOCOUNT) {
  1289.     count = 1;
  1290. }
  1291. if ((count == BINARY_ALL)
  1292. || (count > (length - offset))) {
  1293.     offset = length;
  1294. } else {
  1295.     offset += count;
  1296. }
  1297. break;
  1298.     }
  1299.     case 'X': {
  1300. if (count == BINARY_NOCOUNT) {
  1301.     count = 1;
  1302. }
  1303. if ((count == BINARY_ALL) || (count > offset)) {
  1304.     offset = 0;
  1305. } else {
  1306.     offset -= count;
  1307. }
  1308. break;
  1309.     }
  1310.     case '@': {
  1311. if (count == BINARY_NOCOUNT) {
  1312.     DeleteScanNumberCache(numberCachePtr);
  1313.     goto badCount;
  1314. }
  1315. if ((count == BINARY_ALL) || (count > length)) {
  1316.     offset = length;
  1317. } else {
  1318.     offset = count;
  1319. }
  1320. break;
  1321.     }
  1322.     default: {
  1323. DeleteScanNumberCache(numberCachePtr);
  1324. errorString = str;
  1325. goto badField;
  1326.     }
  1327. }
  1328.     }
  1330.     /*
  1331.      * Set the result to the last position of the cursor.
  1332.      */
  1334.     done:
  1335.     Tcl_ResetResult(interp);
  1336.     Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
  1337.     DeleteScanNumberCache(numberCachePtr);
  1338.     break;
  1339. }
  1340.     }
  1341.     return TCL_OK;
  1343.     badValue:
  1344.     Tcl_ResetResult(interp);
  1345.     Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
  1346.     " string but got "", errorValue, "" instead", NULL);
  1347.     return TCL_ERROR;
  1349.     badCount:
  1350.     errorString = "missing count for "@" field specifier";
  1351.     goto error;
  1353.     badIndex:
  1354.     errorString = "not enough arguments for all format specifiers";
  1355.     goto error;
  1357.     badField:
  1358.     {
  1359. Tcl_UniChar ch;
  1360. char buf[TCL_UTF_MAX + 1];
  1362. Tcl_UtfToUniChar(errorString, &ch);
  1363. buf[Tcl_UniCharToUtf(ch, buf)] = '';
  1364. Tcl_AppendResult(interp, "bad field specifier "", buf, """, NULL);
  1365. return TCL_ERROR;
  1366.     }
  1368.     error:
  1369.     Tcl_AppendResult(interp, errorString, NULL);
  1370.     return TCL_ERROR;
  1371. }
  1373. /*
  1374.  *----------------------------------------------------------------------
  1375.  *
  1376.  * GetFormatSpec --
  1377.  *
  1378.  * This function parses the format strings used in the binary
  1379.  * format and scan commands.
  1380.  *
  1381.  * Results:
  1382.  * Moves the formatPtr to the start of the next command. Returns
  1383.  * the current command character and count in cmdPtr and countPtr.
  1384.  * The count is set to BINARY_ALL if the count character was '*'
  1385.  * or BINARY_NOCOUNT if no count was specified.  Returns 1 on
  1386.  * success, or 0 if the string did not have a format specifier.
  1387.  *
  1388.  * Side effects:
  1389.  * None.
  1390.  *
  1391.  *----------------------------------------------------------------------
  1392.  */
  1394. static int
  1395. GetFormatSpec(formatPtr, cmdPtr, countPtr)
  1396.     char **formatPtr; /* Pointer to format string. */
  1397.     char *cmdPtr; /* Pointer to location of command char. */
  1398.     int *countPtr; /* Pointer to repeat count value. */
  1399. {
  1400.     /*
  1401.      * Skip any leading blanks.
  1402.      */
  1404.     while (**formatPtr == ' ') {
  1405. (*formatPtr)++;
  1406.     }
  1408.     /*
  1409.      * The string was empty, except for whitespace, so fail.
  1410.      */
  1412.     if (!(**formatPtr)) {
  1413. return 0;
  1414.     }
  1416.     /*
  1417.      * Extract the command character and any trailing digits or '*'.
  1418.      */
  1420.     *cmdPtr = **formatPtr;
  1421.     (*formatPtr)++;
  1422.     if (**formatPtr == '*') {
  1423. (*formatPtr)++;
  1424. (*countPtr) = BINARY_ALL;
  1425.     } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
  1426. (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
  1427.     } else {
  1428. (*countPtr) = BINARY_NOCOUNT;
  1429.     }
  1430.     return 1;
  1431. }
  1433. /*
  1434.  *----------------------------------------------------------------------
  1435.  *
  1436.  * FormatNumber --
  1437.  *
  1438.  * This routine is called by Tcl_BinaryObjCmd to format a number
  1439.  * into a location pointed at by cursor.
  1440.  *
  1441.  * Results:
  1442.  *  A standard Tcl result.
  1443.  *
  1444.  * Side effects:
  1445.  * Moves the cursor to the next location to be written into.
  1446.  *
  1447.  *----------------------------------------------------------------------
  1448.  */
  1450. static int
  1451. FormatNumber(interp, type, src, cursorPtr)
  1452.     Tcl_Interp *interp; /* Current interpreter, used to report
  1453.  * errors. */
  1454.     int type; /* Type of number to format. */
  1455.     Tcl_Obj *src; /* Number to format. */
  1456.     unsigned char **cursorPtr; /* Pointer to index into destination buffer. */
  1457. {
  1458.     long value;
  1459.     double dvalue;
  1460.     Tcl_WideInt wvalue;
  1462.     switch (type) {
  1463.     case 'd':
  1464.     case 'f':
  1465. /*
  1466.  * For floating point types, we need to copy the data using
  1467.  * memcpy to avoid alignment issues.
  1468.  */
  1470. if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
  1471.     return TCL_ERROR;
  1472. }
  1473. if (type == 'd') {
  1474.     /*
  1475.      * Can't just memcpy() here. [Bug 1116542]
  1476.      */
  1478.     CopyNumber(&dvalue, *cursorPtr, sizeof(double));
  1479.     *cursorPtr += sizeof(double);
  1480. } else {
  1481.     float fvalue;
  1483.     /*
  1484.      * Because some compilers will generate floating point exceptions
  1485.      * on an overflow cast (e.g. Borland), we restrict the values
  1486.      * to the valid range for float.
  1487.      */
  1489.     if (fabs(dvalue) > (double)FLT_MAX) {
  1490. fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
  1491.     } else {
  1492. fvalue = (float) dvalue;
  1493.     }
  1494.     memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
  1495.     *cursorPtr += sizeof(float);
  1496. }
  1497. return TCL_OK;
  1499. /*
  1500.  * Next cases separate from other integer cases because we
  1501.  * need a different API to get a wide.
  1502.  */
  1503.     case 'w':
  1504.     case 'W':
  1505. if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
  1506.     return TCL_ERROR;
  1507. }
  1508. if (type == 'w') {
  1509.     *(*cursorPtr)++ = (unsigned char) wvalue;
  1510.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
  1511.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
  1512.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
  1513.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
  1514.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
  1515.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
  1516.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
  1517. } else {
  1518.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
  1519.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
  1520.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
  1521.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
  1522.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
  1523.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
  1524.     *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
  1525.     *(*cursorPtr)++ = (unsigned char) wvalue;
  1526. }
  1527. return TCL_OK;
  1528.     default:
  1529. if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
  1530.     return TCL_ERROR;
  1531. }
  1532. if (type == 'c') {
  1533.     *(*cursorPtr)++ = (unsigned char) value;
  1534. } else if (type == 's') {
  1535.     *(*cursorPtr)++ = (unsigned char) value;
  1536.     *(*cursorPtr)++ = (unsigned char) (value >> 8);
  1537. } else if (type == 'S') {
  1538.     *(*cursorPtr)++ = (unsigned char) (value >> 8);
  1539.     *(*cursorPtr)++ = (unsigned char) value;
  1540. } else if (type == 'i') {
  1541.     *(*cursorPtr)++ = (unsigned char) value;
  1542.     *(*cursorPtr)++ = (unsigned char) (value >> 8);
  1543.     *(*cursorPtr)++ = (unsigned char) (value >> 16);
  1544.     *(*cursorPtr)++ = (unsigned char) (value >> 24);
  1545. } else if (type == 'I') {
  1546.     *(*cursorPtr)++ = (unsigned char) (value >> 24);
  1547.     *(*cursorPtr)++ = (unsigned char) (value >> 16);
  1548.     *(*cursorPtr)++ = (unsigned char) (value >> 8);
  1549.     *(*cursorPtr)++ = (unsigned char) value;
  1550. }
  1551. return TCL_OK;
  1552.     }
  1553. }
  1555. /* Ugly workaround for old and broken compiler! */
  1556. static void
  1557. CopyNumber(from, to, length)
  1558.     CONST VOID *from;
  1559.     VOID *to;
  1560.     unsigned int length;
  1561. {
  1562.     memcpy(to, from, length);
  1563. }
  1565. /*
  1566.  *----------------------------------------------------------------------
  1567.  *
  1568.  * ScanNumber --
  1569.  *
  1570.  * This routine is called by Tcl_BinaryObjCmd to scan a number
  1571.  * out of a buffer.
  1572.  *
  1573.  * Results:
  1574.  * Returns a newly created object containing the scanned number.
  1575.  * This object has a ref count of zero.
  1576.  *
  1577.  * Side effects:
  1578.  * Might reuse an object in the number cache, place a new object
  1579.  * in the cache, or delete the cache and set the reference to
  1580.  * it (itself passed in by reference) to NULL.
  1581.  *
  1582.  *----------------------------------------------------------------------
  1583.  */
  1585. static Tcl_Obj *
  1586. ScanNumber(buffer, type, numberCachePtrPtr)
  1587.     unsigned char *buffer; /* Buffer to scan number from. */
  1588.     int type; /* Format character from "binary scan" */
  1589.     Tcl_HashTable **numberCachePtrPtr;
  1590. /* Place to look for cache of scanned
  1591.  * value objects, or NULL if too many
  1592.  * different numbers have been scanned. */
  1593. {
  1594.     long value;
  1595.     Tcl_WideUInt uwvalue;
  1597.     /*
  1598.      * We cannot rely on the compiler to properly sign extend integer values
  1599.      * when we cast from smaller values to larger values because we don't know
  1600.      * the exact size of the integer types.  So, we have to handle sign
  1601.      * extension explicitly by checking the high bit and padding with 1's as
  1602.      * needed.
  1603.      */
  1605.     switch (type) {
  1606. case 'c':
  1607.     /*
  1608.      * Characters need special handling.  We want to produce a
  1609.      * signed result, but on some platforms (such as AIX) chars
  1610.      * are unsigned.  To deal with this, check for a value that
  1611.      * should be negative but isn't.
  1612.      */
  1614.     value = buffer[0];
  1615.     if (value & 0x80) {
  1616. value |= -0x100;
  1617.     }
  1618.     goto returnNumericObject;
  1620. case 's':
  1621.     value = (long) (buffer[0] + (buffer[1] << 8));
  1622.     goto shortValue;
  1623. case 'S':
  1624.     value = (long) (buffer[1] + (buffer[0] << 8));
  1625.     shortValue:
  1626.     if (value & 0x8000) {
  1627. value |= -0x10000;
  1628.     }
  1629.     goto returnNumericObject;
  1631. case 'i':
  1632.     value = (long) (buffer[0] 
  1633.     + (buffer[1] << 8)
  1634.     + (buffer[2] << 16)
  1635.     + (buffer[3] << 24));
  1636.     goto intValue;
  1637. case 'I':
  1638.     value = (long) (buffer[3]
  1639.     + (buffer[2] << 8)
  1640.     + (buffer[1] << 16)
  1641.     + (buffer[0] << 24));
  1642.     intValue:
  1643.     /*
  1644.      * Check to see if the value was sign extended properly on
  1645.      * systems where an int is more than 32-bits.
  1646.      */
  1648.     if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
  1649. value -= (((unsigned int)1)<<31);
  1650. value -= (((unsigned int)1)<<31);
  1651.     }
  1652.     returnNumericObject:
  1653.     if (*numberCachePtrPtr == NULL) {
  1654. return Tcl_NewLongObj(value);
  1655.     } else {
  1656. register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
  1657. register Tcl_HashEntry *hPtr;
  1658. int isNew;
  1660. hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
  1661. if (!isNew) {
  1662.     return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
  1663. }
  1664. if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
  1665.     /*
  1666.      * We've overflowed the cache!  Someone's parsing
  1667.      * a LOT of varied binary data in a single call!
  1668.      * Bail out by switching back to the old behaviour
  1669.      * for the rest of the scan.
  1670.      *
  1671.      * Note that anyone just using the 'c' conversion
  1672.      * (for bytes) cannot trigger this.
  1673.      */
  1674.     DeleteScanNumberCache(tablePtr);
  1675.     *numberCachePtrPtr = NULL;
  1676.     return Tcl_NewLongObj(value);
  1677. } else {
  1678.     register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
  1680.     Tcl_IncrRefCount(objPtr);
  1681.     Tcl_SetHashValue(hPtr, (ClientData) objPtr);
  1682.     return objPtr;
  1683. }
  1684.     }
  1686.     /*
  1687.      * Do not cache wide values; they are already too large to
  1688.      * use as keys.
  1689.      */
  1690. case 'w':
  1691.     uwvalue =  ((Tcl_WideUInt) buffer[0])
  1692.     | (((Tcl_WideUInt) buffer[1]) << 8)
  1693.     | (((Tcl_WideUInt) buffer[2]) << 16)
  1694.     | (((Tcl_WideUInt) buffer[3]) << 24)
  1695.     | (((Tcl_WideUInt) buffer[4]) << 32)
  1696.     | (((Tcl_WideUInt) buffer[5]) << 40)
  1697.     | (((Tcl_WideUInt) buffer[6]) << 48)
  1698.     | (((Tcl_WideUInt) buffer[7]) << 56);
  1699.     return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
  1700. case 'W':
  1701.     uwvalue =  ((Tcl_WideUInt) buffer[7])
  1702.     | (((Tcl_WideUInt) buffer[6]) << 8)
  1703.     | (((Tcl_WideUInt) buffer[5]) << 16)
  1704.     | (((Tcl_WideUInt) buffer[4]) << 24)
  1705.     | (((Tcl_WideUInt) buffer[3]) << 32)
  1706.     | (((Tcl_WideUInt) buffer[2]) << 40)
  1707.     | (((Tcl_WideUInt) buffer[1]) << 48)
  1708.     | (((Tcl_WideUInt) buffer[0]) << 56);
  1709.     return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
  1711.     /*
  1712.      * Do not cache double values; they are already too large
  1713.      * to use as keys and the values stored are utterly
  1714.      * incompatible too.
  1715.      */
  1716. case 'f': {
  1717.     float fvalue;
  1718.     memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
  1719.     return Tcl_NewDoubleObj(fvalue);
  1720. }
  1721. case 'd': {
  1722.     double dvalue;
  1723.     memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
  1724.     return Tcl_NewDoubleObj(dvalue);
  1725. }
  1726.     }
  1727.     return NULL;
  1728. }
  1730. /*
  1731.  *----------------------------------------------------------------------
  1732.  *
  1733.  * DeleteScanNumberCache --
  1734.  * 
  1735.  * Deletes the hash table acting as a scan number cache.
  1736.  *
  1737.  * Results:
  1738.  * None
  1739.  *
  1740.  * Side effects:
  1741.  * Decrements the reference counts of the objects in the cache.
  1742.  *
  1743.  *----------------------------------------------------------------------
  1744.  */
  1746. static void
  1747. DeleteScanNumberCache(numberCachePtr)
  1748.     Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
  1749.  * NULL (when the cache has already
  1750.  * been deleted due to overflow.) */
  1751. {
  1752.     Tcl_HashEntry *hEntry;
  1753.     Tcl_HashSearch search;
  1755.     if (numberCachePtr == NULL) {
  1756. return;
  1757.     }
  1759.     hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
  1760.     while (hEntry != NULL) {
  1761. register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
  1763. if (value != NULL) {
  1764.     Tcl_DecrRefCount(value);
  1765. }
  1766. hEntry = Tcl_NextHashEntry(&search);
  1767.     }
  1768.     Tcl_DeleteHashTable(numberCachePtr);
  1769. }