/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbinary.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclbinary.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.70  
changed lines
  Added in v.71

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25