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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25