Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclBinary.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

File size: 50.2 KB
Line 
1/*
2 * tclBinary.c --
3 *
4 *      This file contains the implementation of the "binary" Tcl built-in
5 *      command and the Tcl binary data object.
6 *
7 * Copyright (c) 1997 by Sun Microsystems, Inc.
8 * Copyright (c) 1998-1999 by Scriptics Corporation.
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclBinary.c,v 1.41 2008/03/24 03:10:06 patthoyts Exp $
14 */
15
16#include "tclInt.h"
17#include "tommath.h"
18
19#include <math.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 * The following flags may be ORed together and returned by GetFormatSpec
31 */
32
33#define BINARY_SIGNED 0         /* Field to be read as signed data */
34#define BINARY_UNSIGNED 1       /* Field to be read as unsigned data */
35
36/*
37 * The following defines the maximum number of different (integer) numbers
38 * placed in the object cache by 'binary scan' before it bails out and
39 * switches back to Plan A (creating a new object for each value.)
40 * Theoretically, it would be possible to keep the cache about for the values
41 * that are already in it, but that makes the code slower in practise when
42 * overflow happens, and makes little odds the rest of the time (as measured
43 * on my machine.) It is also slower (on the sample I tried at least) to grow
44 * the cache to hold all items we might want to put in it; presumably the
45 * extra cost of managing the memory for the enlarged table outweighs the
46 * benefit from allocating fewer objects. This is probably because as the
47 * number of objects increases, the likelihood of reuse of any particular one
48 * drops, and there is very little gain from larger maximum cache sizes (the
49 * value below is chosen to allow caching to work in full with conversion of
50 * bytes.) - DKF
51 */
52
53#define BINARY_SCAN_MAX_CACHE   260
54
55/*
56 * Prototypes for local procedures defined in this file:
57 */
58
59static void             DupByteArrayInternalRep(Tcl_Obj *srcPtr,
60                            Tcl_Obj *copyPtr);
61static int              FormatNumber(Tcl_Interp *interp, int type,
62                            Tcl_Obj *src, unsigned char **cursorPtr);
63static void             FreeByteArrayInternalRep(Tcl_Obj *objPtr);
64static int              GetFormatSpec(char **formatPtr, char *cmdPtr,
65                            int *countPtr, int *flagsPtr);
66static Tcl_Obj *        ScanNumber(unsigned char *buffer, int type,
67                            int flags, Tcl_HashTable **numberCachePtr);
68static int              SetByteArrayFromAny(Tcl_Interp *interp,
69                            Tcl_Obj *objPtr);
70static void             UpdateStringOfByteArray(Tcl_Obj *listPtr);
71static void             DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
72static int              NeedReversing(int format);
73static void             CopyNumber(const void *from, void *to,
74                            unsigned int length, int type);
75
76/*
77 * The following object type represents an array of bytes. An array of bytes
78 * is not equivalent to an internationalized string. Conceptually, a string is
79 * an array of 16-bit quantities organized as a sequence of properly formed
80 * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
81 * Accessor functions are provided to convert a ByteArray to a String or a
82 * String to a ByteArray. Two or more consecutive bytes in an array of bytes
83 * may look like a single UTF-8 character if the array is casually treated as
84 * a string. But obtaining the String from a ByteArray is guaranteed to
85 * produced properly formed UTF-8 sequences so that there is a one-to-one map
86 * between bytes and characters.
87 *
88 * Converting a ByteArray to a String proceeds by casting each byte in the
89 * array to a 16-bit quantity, treating that number as a Unicode character,
90 * and storing the UTF-8 version of that Unicode character in the String. For
91 * ByteArrays consisting entirely of values 1..127, the corresponding String
92 * representation is the same as the ByteArray representation.
93 *
94 * Converting a String to a ByteArray proceeds by getting the Unicode
95 * representation of each character in the String, casting it to a byte by
96 * truncating the upper 8 bits, and then storing the byte in the ByteArray.
97 * Converting from ByteArray to String and back to ByteArray is not lossy, but
98 * converting an arbitrary String to a ByteArray may be.
99 */
100
101Tcl_ObjType tclByteArrayType = {
102    "bytearray",
103    FreeByteArrayInternalRep,
104    DupByteArrayInternalRep,
105    UpdateStringOfByteArray,
106    SetByteArrayFromAny
107};
108
109/*
110 * The following structure is the internal rep for a ByteArray object. Keeps
111 * track of how much memory has been used and how much has been allocated for
112 * the byte array to enable growing and shrinking of the ByteArray object with
113 * fewer mallocs.
114 */
115
116typedef struct ByteArray {
117    int used;                   /* The number of bytes used in the byte
118                                 * array. */
119    int allocated;              /* The amount of space actually allocated
120                                 * minus 1 byte. */
121    unsigned char bytes[4];     /* The array of bytes. The actual size of this
122                                 * field depends on the 'allocated' field
123                                 * above. */
124} ByteArray;
125
126#define BYTEARRAY_SIZE(len) \
127                ((unsigned) (sizeof(ByteArray) - 4 + (len)))
128#define GET_BYTEARRAY(objPtr) \
129                ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
130#define SET_BYTEARRAY(objPtr, baPtr) \
131                (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
132
133
134/*
135 *----------------------------------------------------------------------
136 *
137 * Tcl_NewByteArrayObj --
138 *
139 *      This procedure is creates a new ByteArray object and initializes it
140 *      from the given array of bytes.
141 *
142 * Results:
143 *      The newly create object is returned. This object will have no initial
144 *      string representation. The returned object has a ref count of 0.
145 *
146 * Side effects:
147 *      Memory allocated for new object and copy of byte array argument.
148 *
149 *----------------------------------------------------------------------
150 */
151
152#ifdef TCL_MEM_DEBUG
153#undef Tcl_NewByteArrayObj
154
155Tcl_Obj *
156Tcl_NewByteArrayObj(
157    const unsigned char *bytes, /* The array of bytes used to initialize the
158                                 * new object. */
159    int length)                 /* Length of the array of bytes, which must be
160                                 * >= 0. */
161{
162    return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
163}
164
165#else /* if not TCL_MEM_DEBUG */
166
167Tcl_Obj *
168Tcl_NewByteArrayObj(
169    const unsigned char *bytes, /* The array of bytes used to initialize the
170                                 * new object. */
171    int length)                 /* Length of the array of bytes, which must be
172                                 * >= 0. */
173{
174    Tcl_Obj *objPtr;
175
176    TclNewObj(objPtr);
177    Tcl_SetByteArrayObj(objPtr, bytes, length);
178    return objPtr;
179}
180#endif /* TCL_MEM_DEBUG */
181
182/*
183 *----------------------------------------------------------------------
184 *
185 * Tcl_DbNewByteArrayObj --
186 *
187 *      This procedure is normally called when debugging: i.e., when
188 *      TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
189 *      above except that it calls Tcl_DbCkalloc directly with the file name
190 *      and line number from its caller. This simplifies debugging since then
191 *      the [memory active] command will report the correct file name and line
192 *      number when reporting objects that haven't been freed.
193 *
194 *      When TCL_MEM_DEBUG is not defined, this procedure just returns the
195 *      result of calling Tcl_NewByteArrayObj.
196 *
197 * Results:
198 *      The newly create object is returned. This object will have no initial
199 *      string representation. The returned object has a ref count of 0.
200 *
201 * Side effects:
202 *      Memory allocated for new object and copy of byte array argument.
203 *
204 *----------------------------------------------------------------------
205 */
206
207#ifdef TCL_MEM_DEBUG
208
209Tcl_Obj *
210Tcl_DbNewByteArrayObj(
211    const unsigned char *bytes, /* The array of bytes used to initialize the
212                                 * new object. */
213    int length,                 /* Length of the array of bytes, which must be
214                                 * >= 0. */
215    const char *file,           /* The name of the source file calling this
216                                 * procedure; used for debugging. */
217    int line)                   /* Line number in the source file; used for
218                                 * debugging. */
219{
220    Tcl_Obj *objPtr;
221
222    TclDbNewObj(objPtr, file, line);
223    Tcl_SetByteArrayObj(objPtr, bytes, length);
224    return objPtr;
225}
226
227#else /* if not TCL_MEM_DEBUG */
228
229Tcl_Obj *
230Tcl_DbNewByteArrayObj(
231    const unsigned char *bytes, /* The array of bytes used to initialize the
232                                 * new object. */
233    int length,                 /* Length of the array of bytes, which must be
234                                 * >= 0. */
235    const char *file,           /* The name of the source file calling this
236                                 * procedure; used for debugging. */
237    int line)                   /* Line number in the source file; used for
238                                 * debugging. */
239{
240    return Tcl_NewByteArrayObj(bytes, length);
241}
242#endif /* TCL_MEM_DEBUG */
243
244/*
245 *---------------------------------------------------------------------------
246 *
247 * Tcl_SetByteArrayObj --
248 *
249 *      Modify an object to be a ByteArray object and to have the specified
250 *      array of bytes as its value.
251 *
252 * Results:
253 *      None.
254 *
255 * Side effects:
256 *      The object's old string rep and internal rep is freed. Memory
257 *      allocated for copy of byte array argument.
258 *
259 *----------------------------------------------------------------------
260 */
261
262void
263Tcl_SetByteArrayObj(
264    Tcl_Obj *objPtr,            /* Object to initialize as a ByteArray. */
265    const unsigned char *bytes, /* The array of bytes to use as the new
266                                 * value. */
267    int length)                 /* Length of the array of bytes, which must be
268                                 * >= 0. */
269{
270    ByteArray *byteArrayPtr;
271
272    if (Tcl_IsShared(objPtr)) {
273        Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj");
274    }
275    TclFreeIntRep(objPtr);
276    Tcl_InvalidateStringRep(objPtr);
277
278    byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
279    byteArrayPtr->used = length;
280    byteArrayPtr->allocated = length;
281    memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
282
283    objPtr->typePtr = &tclByteArrayType;
284    SET_BYTEARRAY(objPtr, byteArrayPtr);
285}
286
287/*
288 *----------------------------------------------------------------------
289 *
290 * Tcl_GetByteArrayFromObj --
291 *
292 *      Attempt to get the array of bytes from the Tcl object. If the object
293 *      is not already a ByteArray object, an attempt will be made to convert
294 *      it to one.
295 *
296 * Results:
297 *      Pointer to array of bytes representing the ByteArray object.
298 *
299 * Side effects:
300 *      Frees old internal rep. Allocates memory for new internal rep.
301 *
302 *----------------------------------------------------------------------
303 */
304
305unsigned char *
306Tcl_GetByteArrayFromObj(
307    Tcl_Obj *objPtr,            /* The ByteArray object. */
308    int *lengthPtr)             /* If non-NULL, filled with length of the
309                                 * array of bytes in the ByteArray object. */
310{
311    ByteArray *baPtr;
312
313    if (objPtr->typePtr != &tclByteArrayType) {
314        SetByteArrayFromAny(NULL, objPtr);
315    }
316    baPtr = GET_BYTEARRAY(objPtr);
317
318    if (lengthPtr != NULL) {
319        *lengthPtr = baPtr->used;
320    }
321    return (unsigned char *) baPtr->bytes;
322}
323
324/*
325 *----------------------------------------------------------------------
326 *
327 * Tcl_SetByteArrayLength --
328 *
329 *      This procedure changes the length of the byte array for this object.
330 *      Once the caller has set the length of the array, it is acceptable to
331 *      directly modify the bytes in the array up until Tcl_GetStringFromObj()
332 *      has been called on this object.
333 *
334 * Results:
335 *      The new byte array of the specified length.
336 *
337 * Side effects:
338 *      Allocates enough memory for an array of bytes of the requested size.
339 *      When growing the array, the old array is copied to the new array; new
340 *      bytes are undefined. When shrinking, the old array is truncated to the
341 *      specified length.
342 *
343 *----------------------------------------------------------------------
344 */
345
346unsigned char *
347Tcl_SetByteArrayLength(
348    Tcl_Obj *objPtr,            /* The ByteArray object. */
349    int length)                 /* New length for internal byte array. */
350{
351    ByteArray *byteArrayPtr;
352
353    if (Tcl_IsShared(objPtr)) {
354        Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
355    }
356    if (objPtr->typePtr != &tclByteArrayType) {
357        SetByteArrayFromAny(NULL, objPtr);
358    }
359
360    byteArrayPtr = GET_BYTEARRAY(objPtr);
361    if (length > byteArrayPtr->allocated) {
362        byteArrayPtr = (ByteArray *) ckrealloc(
363                (char *) byteArrayPtr, BYTEARRAY_SIZE(length));
364        byteArrayPtr->allocated = length;
365        SET_BYTEARRAY(objPtr, byteArrayPtr);
366    }
367    Tcl_InvalidateStringRep(objPtr);
368    byteArrayPtr->used = length;
369    return byteArrayPtr->bytes;
370}
371
372/*
373 *----------------------------------------------------------------------
374 *
375 * SetByteArrayFromAny --
376 *
377 *      Generate the ByteArray internal rep from the string rep.
378 *
379 * Results:
380 *      The return value is always TCL_OK.
381 *
382 * Side effects:
383 *      A ByteArray object is stored as the internal rep of objPtr.
384 *
385 *----------------------------------------------------------------------
386 */
387
388static int
389SetByteArrayFromAny(
390    Tcl_Interp *interp,         /* Not used. */
391    Tcl_Obj *objPtr)            /* The object to convert to type ByteArray. */
392{
393    int length;
394    char *src, *srcEnd;
395    unsigned char *dst;
396    ByteArray *byteArrayPtr;
397    Tcl_UniChar ch;
398
399    if (objPtr->typePtr != &tclByteArrayType) {
400        src = TclGetStringFromObj(objPtr, &length);
401        srcEnd = src + length;
402
403        byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
404        for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
405            src += Tcl_UtfToUniChar(src, &ch);
406            *dst++ = (unsigned char) ch;
407        }
408
409        byteArrayPtr->used = dst - byteArrayPtr->bytes;
410        byteArrayPtr->allocated = length;
411
412        TclFreeIntRep(objPtr);
413        objPtr->typePtr = &tclByteArrayType;
414        SET_BYTEARRAY(objPtr, byteArrayPtr);
415    }
416    return TCL_OK;
417}
418
419/*
420 *----------------------------------------------------------------------
421 *
422 * FreeByteArrayInternalRep --
423 *
424 *      Deallocate the storage associated with a ByteArray data object's
425 *      internal representation.
426 *
427 * Results:
428 *      None.
429 *
430 * Side effects:
431 *      Frees memory.
432 *
433 *----------------------------------------------------------------------
434 */
435
436static void
437FreeByteArrayInternalRep(
438    Tcl_Obj *objPtr)            /* Object with internal rep to free. */
439{
440    ckfree((char *) GET_BYTEARRAY(objPtr));
441}
442
443/*
444 *----------------------------------------------------------------------
445 *
446 * DupByteArrayInternalRep --
447 *
448 *      Initialize the internal representation of a ByteArray Tcl_Obj to a
449 *      copy of the internal representation of an existing ByteArray object.
450 *
451 * Results:
452 *      None.
453 *
454 * Side effects:
455 *      Allocates memory.
456 *
457 *----------------------------------------------------------------------
458 */
459
460static void
461DupByteArrayInternalRep(
462    Tcl_Obj *srcPtr,            /* Object with internal rep to copy. */
463    Tcl_Obj *copyPtr)           /* Object with internal rep to set. */
464{
465    int length;
466    ByteArray *srcArrayPtr, *copyArrayPtr;
467
468    srcArrayPtr = GET_BYTEARRAY(srcPtr);
469    length = srcArrayPtr->used;
470
471    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
472    copyArrayPtr->used = length;
473    copyArrayPtr->allocated = length;
474    memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
475    SET_BYTEARRAY(copyPtr, copyArrayPtr);
476
477    copyPtr->typePtr = &tclByteArrayType;
478}
479
480/*
481 *----------------------------------------------------------------------
482 *
483 * UpdateStringOfByteArray --
484 *
485 *      Update the string representation for a ByteArray data object. Note:
486 *      This procedure does not invalidate an existing old string rep so
487 *      storage will be lost if this has not already been done.
488 *
489 * Results:
490 *      None.
491 *
492 * Side effects:
493 *      The object's string is set to a valid string that results from the
494 *      ByteArray-to-string conversion.
495 *
496 *      The object becomes a string object -- the internal rep is discarded
497 *      and the typePtr becomes NULL.
498 *
499 *----------------------------------------------------------------------
500 */
501
502static void
503UpdateStringOfByteArray(
504    Tcl_Obj *objPtr)            /* ByteArray object whose string rep to
505                                 * update. */
506{
507    int i, length, size;
508    unsigned char *src;
509    char *dst;
510    ByteArray *byteArrayPtr;
511
512    byteArrayPtr = GET_BYTEARRAY(objPtr);
513    src = byteArrayPtr->bytes;
514    length = byteArrayPtr->used;
515
516    /*
517     * How much space will string rep need?
518     */
519
520    size = length;
521    for (i = 0; i < length; i++) {
522        if ((src[i] == 0) || (src[i] > 127)) {
523            size++;
524        }
525    }
526
527    dst = (char *) ckalloc((unsigned) (size + 1));
528    objPtr->bytes = dst;
529    objPtr->length = size;
530
531    if (size == length) {
532        memcpy(dst, src, (size_t) size);
533        dst[size] = '\0';
534    } else {
535        for (i = 0; i < length; i++) {
536            dst += Tcl_UniCharToUtf(src[i], dst);
537        }
538        *dst = '\0';
539    }
540}
541
542/*
543 *----------------------------------------------------------------------
544 *
545 * Tcl_BinaryObjCmd --
546 *
547 *      This procedure implements the "binary" Tcl command.
548 *
549 * Results:
550 *      A standard Tcl result.
551 *
552 * Side effects:
553 *      See the user documentation.
554 *
555 *----------------------------------------------------------------------
556 */
557
558int
559Tcl_BinaryObjCmd(
560    ClientData dummy,           /* Not used. */
561    Tcl_Interp *interp,         /* Current interpreter. */
562    int objc,                   /* Number of arguments. */
563    Tcl_Obj *const objv[])      /* Argument objects. */
564{
565    int arg;                    /* Index of next argument to consume. */
566    int value = 0;              /* Current integer value to be packed.
567                                 * Initialized to avoid compiler warning. */
568    char cmd;                   /* Current format character. */
569    int count;                  /* Count associated with current format
570                                 * character. */
571    int flags;                  /* Format field flags */
572    char *format;               /* Pointer to current position in format
573                                 * string. */
574    Tcl_Obj *resultPtr = NULL;  /* Object holding result buffer. */
575    unsigned char *buffer;      /* Start of result buffer. */
576    unsigned char *cursor;      /* Current position within result buffer. */
577    unsigned char *maxPos;      /* Greatest position within result buffer that
578                                 * cursor has visited.*/
579    const char *errorString;
580    char *errorValue, *str;
581    int offset, size, length, index;
582    static const char *options[] = {
583        "format",       "scan",         NULL
584    };
585    enum options {
586        BINARY_FORMAT,  BINARY_SCAN
587    };
588
589    if (objc < 2) {
590        Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
591        return TCL_ERROR;
592    }
593
594    if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
595            &index) != TCL_OK) {
596        return TCL_ERROR;
597    }
598
599    switch ((enum options) index) {
600    case BINARY_FORMAT:
601        if (objc < 3) {
602            Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
603            return TCL_ERROR;
604        }
605
606        /*
607         * To avoid copying the data, we format the string in two passes. The
608         * first pass computes the size of the output buffer. The second pass
609         * places the formatted data into the buffer.
610         */
611
612        format = TclGetString(objv[2]);
613        arg = 3;
614        offset = 0;
615        length = 0;
616        while (*format != '\0') {
617            str = format;
618            flags = 0;
619            if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
620                break;
621            }
622            switch (cmd) {
623            case 'a':
624            case 'A':
625            case 'b':
626            case 'B':
627            case 'h':
628            case 'H':
629                /*
630                 * For string-type specifiers, the count corresponds to the
631                 * number of bytes in a single argument.
632                 */
633
634                if (arg >= objc) {
635                    goto badIndex;
636                }
637                if (count == BINARY_ALL) {
638                    Tcl_GetByteArrayFromObj(objv[arg], &count);
639                } else if (count == BINARY_NOCOUNT) {
640                    count = 1;
641                }
642                arg++;
643                if (cmd == 'a' || cmd == 'A') {
644                    offset += count;
645                } else if (cmd == 'b' || cmd == 'B') {
646                    offset += (count + 7) / 8;
647                } else {
648                    offset += (count + 1) / 2;
649                }
650                break;
651            case 'c':
652                size = 1;
653                goto doNumbers;
654            case 't':
655            case 's':
656            case 'S':
657                size = 2;
658                goto doNumbers;
659            case 'n':
660            case 'i':
661            case 'I':
662                size = 4;
663                goto doNumbers;
664            case 'm':
665            case 'w':
666            case 'W':
667                size = 8;
668                goto doNumbers;
669            case 'r':
670            case 'R':
671            case 'f':
672                size = sizeof(float);
673                goto doNumbers;
674            case 'q':
675            case 'Q':
676            case 'd':
677                size = sizeof(double);
678
679            doNumbers:
680                if (arg >= objc) {
681                    goto badIndex;
682                }
683
684                /*
685                 * For number-type specifiers, the count corresponds to the
686                 * number of elements in the list stored in a single argument.
687                 * If no count is specified, then the argument is taken as a
688                 * single non-list value.
689                 */
690
691                if (count == BINARY_NOCOUNT) {
692                    arg++;
693                    count = 1;
694                } else {
695                    int listc;
696                    Tcl_Obj **listv;
697
698                    /* The macro evals its args more than once: avoid arg++ */             
699                    if (TclListObjGetElements(interp, objv[arg], &listc,
700                            &listv) != TCL_OK) {
701                        return TCL_ERROR;
702                    }
703                    arg++;
704                   
705                    if (count == BINARY_ALL) {
706                        count = listc;
707                    } else if (count > listc) {
708                        Tcl_AppendResult(interp,
709                                "number of elements in list does not match count",
710                                NULL);
711                        return TCL_ERROR;
712                    }
713                }
714                offset += count*size;
715                break;
716
717            case 'x':
718                if (count == BINARY_ALL) {
719                    Tcl_AppendResult(interp,
720                            "cannot use \"*\" in format string with \"x\"",
721                            NULL);
722                    return TCL_ERROR;
723                } else if (count == BINARY_NOCOUNT) {
724                    count = 1;
725                }
726                offset += count;
727                break;
728            case 'X':
729                if (count == BINARY_NOCOUNT) {
730                    count = 1;
731                }
732                if ((count > offset) || (count == BINARY_ALL)) {
733                    count = offset;
734                }
735                if (offset > length) {
736                    length = offset;
737                }
738                offset -= count;
739                break;
740            case '@':
741                if (offset > length) {
742                    length = offset;
743                }
744                if (count == BINARY_ALL) {
745                    offset = length;
746                } else if (count == BINARY_NOCOUNT) {
747                    goto badCount;
748                } else {
749                    offset = count;
750                }
751                break;
752            default:
753                errorString = str;
754                goto badField;
755            }
756        }
757        if (offset > length) {
758            length = offset;
759        }
760        if (length == 0) {
761            return TCL_OK;
762        }
763
764        /*
765         * Prepare the result object by preallocating the caclulated number of
766         * bytes and filling with nulls.
767         */
768
769        resultPtr = Tcl_NewObj();
770        buffer = Tcl_SetByteArrayLength(resultPtr, length);
771        memset(buffer, 0, (size_t) length);
772
773        /*
774         * Pack the data into the result object. Note that we can skip the
775         * error checking during this pass, since we have already parsed the
776         * string once.
777         */
778
779        arg = 3;
780        format = TclGetString(objv[2]);
781        cursor = buffer;
782        maxPos = cursor;
783        while (*format != 0) {
784            flags = 0;
785            if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
786                break;
787            }
788            if ((count == 0) && (cmd != '@')) {
789                if (cmd != 'x') {
790                    arg++;
791                }
792                continue;
793            }
794            switch (cmd) {
795            case 'a':
796            case 'A': {
797                char pad = (char) (cmd == 'a' ? '\0' : ' ');
798                unsigned char *bytes;
799
800                bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
801
802                if (count == BINARY_ALL) {
803                    count = length;
804                } else if (count == BINARY_NOCOUNT) {
805                    count = 1;
806                }
807                if (length >= count) {
808                    memcpy(cursor, bytes, (size_t) count);
809                } else {
810                    memcpy(cursor, bytes, (size_t) length);
811                    memset(cursor + length, pad, (size_t) (count - length));
812                }
813                cursor += count;
814                break;
815            }
816            case 'b':
817            case 'B': {
818                unsigned char *last;
819
820                str = TclGetStringFromObj(objv[arg], &length);
821                arg++;
822                if (count == BINARY_ALL) {
823                    count = length;
824                } else if (count == BINARY_NOCOUNT) {
825                    count = 1;
826                }
827                last = cursor + ((count + 7) / 8);
828                if (count > length) {
829                    count = length;
830                }
831                value = 0;
832                errorString = "binary";
833                if (cmd == 'B') {
834                    for (offset = 0; offset < count; offset++) {
835                        value <<= 1;
836                        if (str[offset] == '1') {
837                            value |= 1;
838                        } else if (str[offset] != '0') {
839                            errorValue = str;
840                            Tcl_DecrRefCount(resultPtr);
841                            goto badValue;
842                        }
843                        if (((offset + 1) % 8) == 0) {
844                            *cursor++ = (unsigned char) value;
845                            value = 0;
846                        }
847                    }
848                } else {
849                    for (offset = 0; offset < count; offset++) {
850                        value >>= 1;
851                        if (str[offset] == '1') {
852                            value |= 128;
853                        } else if (str[offset] != '0') {
854                            errorValue = str;
855                            Tcl_DecrRefCount(resultPtr);
856                            goto badValue;
857                        }
858                        if (!((offset + 1) % 8)) {
859                            *cursor++ = (unsigned char) value;
860                            value = 0;
861                        }
862                    }
863                }
864                if ((offset % 8) != 0) {
865                    if (cmd == 'B') {
866                        value <<= 8 - (offset % 8);
867                    } else {
868                        value >>= 8 - (offset % 8);
869                    }
870                    *cursor++ = (unsigned char) value;
871                }
872                while (cursor < last) {
873                    *cursor++ = '\0';
874                }
875                break;
876            }
877            case 'h':
878            case 'H': {
879                unsigned char *last;
880                int c;
881
882                str = TclGetStringFromObj(objv[arg], &length);
883                arg++;
884                if (count == BINARY_ALL) {
885                    count = length;
886                } else if (count == BINARY_NOCOUNT) {
887                    count = 1;
888                }
889                last = cursor + ((count + 1) / 2);
890                if (count > length) {
891                    count = length;
892                }
893                value = 0;
894                errorString = "hexadecimal";
895                if (cmd == 'H') {
896                    for (offset = 0; offset < count; offset++) {
897                        value <<= 4;
898                        if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
899                            errorValue = str;
900                            Tcl_DecrRefCount(resultPtr);
901                            goto badValue;
902                        }
903                        c = str[offset] - '0';
904                        if (c > 9) {
905                            c += ('0' - 'A') + 10;
906                        }
907                        if (c > 16) {
908                            c += ('A' - 'a');
909                        }
910                        value |= (c & 0xf);
911                        if (offset % 2) {
912                            *cursor++ = (char) value;
913                            value = 0;
914                        }
915                    }
916                } else {
917                    for (offset = 0; offset < count; offset++) {
918                        value >>= 4;
919
920                        if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
921                            errorValue = str;
922                            Tcl_DecrRefCount(resultPtr);
923                            goto badValue;
924                        }
925                        c = str[offset] - '0';
926                        if (c > 9) {
927                            c += ('0' - 'A') + 10;
928                        }
929                        if (c > 16) {
930                            c += ('A' - 'a');
931                        }
932                        value |= ((c << 4) & 0xf0);
933                        if (offset % 2) {
934                            *cursor++ = (unsigned char)(value & 0xff);
935                            value = 0;
936                        }
937                    }
938                }
939                if (offset % 2) {
940                    if (cmd == 'H') {
941                        value <<= 4;
942                    } else {
943                        value >>= 4;
944                    }
945                    *cursor++ = (unsigned char) value;
946                }
947
948                while (cursor < last) {
949                    *cursor++ = '\0';
950                }
951                break;
952            }
953            case 'c':
954            case 't':
955            case 's':
956            case 'S':
957            case 'n':
958            case 'i':
959            case 'I':
960            case 'm':
961            case 'w':
962            case 'W':
963            case 'r':
964            case 'R':
965            case 'd':
966            case 'q':
967            case 'Q':
968            case 'f': {
969                int listc, i;
970                Tcl_Obj **listv;
971
972                if (count == BINARY_NOCOUNT) {
973                    /*
974                     * Note that we are casting away the const-ness of objv,
975                     * but this is safe since we aren't going to modify the
976                     * array.
977                     */
978
979                    listv = (Tcl_Obj**)(objv + arg);
980                    listc = 1;
981                    count = 1;
982                } else {
983                    TclListObjGetElements(interp, objv[arg], &listc, &listv);
984                    if (count == BINARY_ALL) {
985                        count = listc;
986                    }
987                }
988                arg++;
989                for (i = 0; i < count; i++) {
990                    if (FormatNumber(interp, cmd, listv[i], &cursor)!=TCL_OK) {
991                        Tcl_DecrRefCount(resultPtr);
992                        return TCL_ERROR;
993                    }
994                }
995                break;
996            }
997            case 'x':
998                if (count == BINARY_NOCOUNT) {
999                    count = 1;
1000                }
1001                memset(cursor, 0, (size_t) count);
1002                cursor += count;
1003                break;
1004            case 'X':
1005                if (cursor > maxPos) {
1006                    maxPos = cursor;
1007                }
1008                if (count == BINARY_NOCOUNT) {
1009                    count = 1;
1010                }
1011                if ((count == BINARY_ALL) || (count > (cursor - buffer))) {
1012                    cursor = buffer;
1013                } else {
1014                    cursor -= count;
1015                }
1016                break;
1017            case '@':
1018                if (cursor > maxPos) {
1019                    maxPos = cursor;
1020                }
1021                if (count == BINARY_ALL) {
1022                    cursor = maxPos;
1023                } else {
1024                    cursor = buffer + count;
1025                }
1026                break;
1027            }
1028        }
1029        Tcl_SetObjResult(interp, resultPtr);
1030        break;
1031    case BINARY_SCAN: {
1032        int i;
1033        Tcl_Obj *valuePtr, *elementPtr;
1034        Tcl_HashTable numberCacheHash;
1035        Tcl_HashTable *numberCachePtr;
1036
1037        if (objc < 4) {
1038            Tcl_WrongNumArgs(interp, 2, objv,
1039                    "value formatString ?varName varName ...?");
1040            return TCL_ERROR;
1041        }
1042        numberCachePtr = &numberCacheHash;
1043        Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
1044        buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
1045        format = TclGetString(objv[3]);
1046        cursor = buffer;
1047        arg = 4;
1048        offset = 0;
1049        while (*format != '\0') {
1050            str = format;
1051            flags = 0;
1052            if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
1053                goto done;
1054            }
1055            switch (cmd) {
1056            case 'a':
1057            case 'A': {
1058                unsigned char *src;
1059
1060                if (arg >= objc) {
1061                    DeleteScanNumberCache(numberCachePtr);
1062                    goto badIndex;
1063                }
1064                if (count == BINARY_ALL) {
1065                    count = length - offset;
1066                } else {
1067                    if (count == BINARY_NOCOUNT) {
1068                        count = 1;
1069                    }
1070                    if (count > (length - offset)) {
1071                        goto done;
1072                    }
1073                }
1074
1075                src = buffer + offset;
1076                size = count;
1077
1078                /*
1079                 * Trim trailing nulls and spaces, if necessary.
1080                 */
1081
1082                if (cmd == 'A') {
1083                    while (size > 0) {
1084                        if (src[size-1] != '\0' && src[size-1] != ' ') {
1085                            break;
1086                        }
1087                        size--;
1088                    }
1089                }
1090
1091                /*
1092                 * Have to do this #ifdef-fery because (as part of defining
1093                 * Tcl_NewByteArrayObj) we removed the #def that hides this
1094                 * stuff normally. If this code ever gets copied to another
1095                 * file, it should be changed back to the simpler version.
1096                 */
1097
1098#ifdef TCL_MEM_DEBUG
1099                valuePtr = Tcl_DbNewByteArrayObj(src, size, __FILE__,__LINE__);
1100#else
1101                valuePtr = Tcl_NewByteArrayObj(src, size);
1102#endif /* TCL_MEM_DEBUG */
1103
1104                resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
1105                        TCL_LEAVE_ERR_MSG);
1106                arg++;
1107                if (resultPtr == NULL) {
1108                    DeleteScanNumberCache(numberCachePtr);
1109                    return TCL_ERROR;
1110                }
1111                offset += count;
1112                break;
1113            }
1114            case 'b':
1115            case 'B': {
1116                unsigned char *src;
1117                char *dest;
1118
1119                if (arg >= objc) {
1120                    DeleteScanNumberCache(numberCachePtr);
1121                    goto badIndex;
1122                }
1123                if (count == BINARY_ALL) {
1124                    count = (length - offset) * 8;
1125                } else {
1126                    if (count == BINARY_NOCOUNT) {
1127                        count = 1;
1128                    }
1129                    if (count > (length - offset) * 8) {
1130                        goto done;
1131                    }
1132                }
1133                src = buffer + offset;
1134                valuePtr = Tcl_NewObj();
1135                Tcl_SetObjLength(valuePtr, count);
1136                dest = TclGetString(valuePtr);
1137
1138                if (cmd == 'b') {
1139                    for (i = 0; i < count; i++) {
1140                        if (i % 8) {
1141                            value >>= 1;
1142                        } else {
1143                            value = *src++;
1144                        }
1145                        *dest++ = (char) ((value & 1) ? '1' : '0');
1146                    }
1147                } else {
1148                    for (i = 0; i < count; i++) {
1149                        if (i % 8) {
1150                            value <<= 1;
1151                        } else {
1152                            value = *src++;
1153                        }
1154                        *dest++ = (char) ((value & 0x80) ? '1' : '0');
1155                    }
1156                }
1157
1158                resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
1159                        TCL_LEAVE_ERR_MSG);
1160                arg++;
1161                if (resultPtr == NULL) {
1162                    DeleteScanNumberCache(numberCachePtr);
1163                    return TCL_ERROR;
1164                }
1165                offset += (count + 7) / 8;
1166                break;
1167            }
1168            case 'h':
1169            case 'H': {
1170                char *dest;
1171                unsigned char *src;
1172                int i;
1173                static const char hexdigit[] = "0123456789abcdef";
1174
1175                if (arg >= objc) {
1176                    DeleteScanNumberCache(numberCachePtr);
1177                    goto badIndex;
1178                }
1179                if (count == BINARY_ALL) {
1180                    count = (length - offset)*2;
1181                } else {
1182                    if (count == BINARY_NOCOUNT) {
1183                        count = 1;
1184                    }
1185                    if (count > (length - offset)*2) {
1186                        goto done;
1187                    }
1188                }
1189                src = buffer + offset;
1190                valuePtr = Tcl_NewObj();
1191                Tcl_SetObjLength(valuePtr, count);
1192                dest = TclGetString(valuePtr);
1193
1194                if (cmd == 'h') {
1195                    for (i = 0; i < count; i++) {
1196                        if (i % 2) {
1197                            value >>= 4;
1198                        } else {
1199                            value = *src++;
1200                        }
1201                        *dest++ = hexdigit[value & 0xf];
1202                    }
1203                } else {
1204                    for (i = 0; i < count; i++) {
1205                        if (i % 2) {
1206                            value <<= 4;
1207                        } else {
1208                            value = *src++;
1209                        }
1210                        *dest++ = hexdigit[(value >> 4) & 0xf];
1211                    }
1212                }
1213
1214                resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
1215                        TCL_LEAVE_ERR_MSG);
1216                arg++;
1217                if (resultPtr == NULL) {
1218                    DeleteScanNumberCache(numberCachePtr);
1219                    return TCL_ERROR;
1220                }
1221                offset += (count + 1) / 2;
1222                break;
1223            }
1224            case 'c':
1225                size = 1;
1226                goto scanNumber;
1227            case 't':
1228            case 's':
1229            case 'S':
1230                size = 2;
1231                goto scanNumber;
1232            case 'n':
1233            case 'i':
1234            case 'I':
1235                size = 4;
1236                goto scanNumber;
1237            case 'm':
1238            case 'w':
1239            case 'W':
1240                size = 8;
1241                goto scanNumber;
1242            case 'r':
1243            case 'R':
1244            case 'f':
1245                size = sizeof(float);
1246                goto scanNumber;
1247            case 'q':
1248            case 'Q':
1249            case 'd': {
1250                unsigned char *src;
1251
1252                size = sizeof(double);
1253                /* fall through */
1254
1255            scanNumber:
1256                if (arg >= objc) {
1257                    DeleteScanNumberCache(numberCachePtr);
1258                    goto badIndex;
1259                }
1260                if (count == BINARY_NOCOUNT) {
1261                    if ((length - offset) < size) {
1262                        goto done;
1263                    }
1264                    valuePtr = ScanNumber(buffer+offset, cmd, flags,
1265                            &numberCachePtr);
1266                    offset += size;
1267                } else {
1268                    if (count == BINARY_ALL) {
1269                        count = (length - offset) / size;
1270                    }
1271                    if ((length - offset) < (count * size)) {
1272                        goto done;
1273                    }
1274                    valuePtr = Tcl_NewObj();
1275                    src = buffer+offset;
1276                    for (i = 0; i < count; i++) {
1277                        elementPtr = ScanNumber(src, cmd, flags,
1278                                &numberCachePtr);
1279                        src += size;
1280                        Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
1281                    }
1282                    offset += count*size;
1283                }
1284
1285                resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
1286                        TCL_LEAVE_ERR_MSG);
1287                arg++;
1288                if (resultPtr == NULL) {
1289                    DeleteScanNumberCache(numberCachePtr);
1290                    return TCL_ERROR;
1291                }
1292                break;
1293            }
1294            case 'x':
1295                if (count == BINARY_NOCOUNT) {
1296                    count = 1;
1297                }
1298                if ((count == BINARY_ALL) || (count > (length - offset))) {
1299                    offset = length;
1300                } else {
1301                    offset += count;
1302                }
1303                break;
1304            case 'X':
1305                if (count == BINARY_NOCOUNT) {
1306                    count = 1;
1307                }
1308                if ((count == BINARY_ALL) || (count > offset)) {
1309                    offset = 0;
1310                } else {
1311                    offset -= count;
1312                }
1313                break;
1314            case '@':
1315                if (count == BINARY_NOCOUNT) {
1316                    DeleteScanNumberCache(numberCachePtr);
1317                    goto badCount;
1318                }
1319                if ((count == BINARY_ALL) || (count > length)) {
1320                    offset = length;
1321                } else {
1322                    offset = count;
1323                }
1324                break;
1325            default:
1326                DeleteScanNumberCache(numberCachePtr);
1327                errorString = str;
1328                goto badField;
1329            }
1330        }
1331
1332        /*
1333         * Set the result to the last position of the cursor.
1334         */
1335
1336    done:
1337        Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4));
1338        DeleteScanNumberCache(numberCachePtr);
1339        break;
1340    }
1341    }
1342    return TCL_OK;
1343
1344  badValue:
1345    Tcl_ResetResult(interp);
1346    Tcl_AppendResult(interp, "expected ", errorString,
1347            " string but got \"", errorValue, "\" instead", NULL);
1348    return TCL_ERROR;
1349
1350  badCount:
1351    errorString = "missing count for \"@\" field specifier";
1352    goto error;
1353
1354  badIndex:
1355    errorString = "not enough arguments for all format specifiers";
1356    goto error;
1357
1358  badField:
1359    {
1360        Tcl_UniChar ch;
1361        char buf[TCL_UTF_MAX + 1];
1362
1363        Tcl_UtfToUniChar(errorString, &ch);
1364        buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
1365        Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
1366        return TCL_ERROR;
1367    }
1368
1369  error:
1370    Tcl_AppendResult(interp, errorString, NULL);
1371    return TCL_ERROR;
1372}
1373
1374/*
1375 *----------------------------------------------------------------------
1376 *
1377 * GetFormatSpec --
1378 *
1379 *      This function parses the format strings used in the binary format and
1380 *      scan commands.
1381 *
1382 * Results:
1383 *      Moves the formatPtr to the start of the next command. Returns the
1384 *      current command character and count in cmdPtr and countPtr. The count
1385 *      is set to BINARY_ALL if the count character was '*' or BINARY_NOCOUNT
1386 *      if no count was specified. Returns 1 on success, or 0 if the string
1387 *      did not have a format specifier.
1388 *
1389 * Side effects:
1390 *      None.
1391 *
1392 *----------------------------------------------------------------------
1393 */
1394
1395static int
1396GetFormatSpec(
1397    char **formatPtr,           /* Pointer to format string. */
1398    char *cmdPtr,               /* Pointer to location of command char. */
1399    int *countPtr,              /* Pointer to repeat count value. */
1400    int *flagsPtr)              /* Pointer to field flags */
1401{
1402    /*
1403     * Skip any leading blanks.
1404     */
1405
1406    while (**formatPtr == ' ') {
1407        (*formatPtr)++;
1408    }
1409
1410    /*
1411     * The string was empty, except for whitespace, so fail.
1412     */
1413
1414    if (!(**formatPtr)) {
1415        return 0;
1416    }
1417
1418    /*
1419     * Extract the command character and any trailing digits or '*'.
1420     */
1421
1422    *cmdPtr = **formatPtr;
1423    (*formatPtr)++;
1424    if (**formatPtr == 'u') {
1425        (*formatPtr)++;
1426        (*flagsPtr) |= BINARY_UNSIGNED;
1427    }
1428    if (**formatPtr == '*') {
1429        (*formatPtr)++;
1430        (*countPtr) = BINARY_ALL;
1431    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
1432        (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
1433    } else {
1434        (*countPtr) = BINARY_NOCOUNT;
1435    }
1436    return 1;
1437}
1438
1439/*
1440 *----------------------------------------------------------------------
1441 *
1442 * NeedReversing --
1443 *
1444 *      This routine determines, if bytes of a number need to be re-ordered,
1445 *      and returns a numeric code indicating the re-ordering to be done.
1446 *      This depends on the endiannes of the machine and the desired format.
1447 *      It is in effect a table (whose contents depend on the endianness of
1448 *      the system) describing whether a value needs reversing or not. Anyone
1449 *      porting the code to a big-endian platform should take care to make
1450 *      sure that they define WORDS_BIGENDIAN though this is already done by
1451 *      configure for the Unix build; little-endian platforms (including
1452 *      Windows) don't need to do anything.
1453 *
1454 * Results:
1455 *      0       No re-ordering needed.
1456 *      1       Reverse the bytes:      01234567 <-> 76543210 (little to big)
1457 *      2       Apply this re-ordering: 01234567 <-> 45670123 (Nokia to little)
1458 *      3       Apply this re-ordering: 01234567 <-> 32107654 (Nokia to big)
1459 *
1460 * Side effects:
1461 *      None
1462 *
1463 *----------------------------------------------------------------------
1464 */
1465
1466static int
1467NeedReversing(
1468    int format)
1469{
1470    switch (format) {
1471        /* native floats and doubles: never reverse */
1472    case 'd':
1473    case 'f':
1474        /* big endian ints: never reverse */
1475    case 'I':
1476    case 'S':
1477    case 'W':
1478#ifdef WORDS_BIGENDIAN
1479        /* native ints: reverse if we're little-endian */
1480    case 'n':
1481    case 't':
1482    case 'm':
1483        /* f: reverse if we're little-endian */
1484    case 'Q':
1485    case 'R':
1486#else /* !WORDS_BIGENDIAN */
1487        /* small endian floats: reverse if we're big-endian */
1488    case 'r':
1489#endif /* WORDS_BIGENDIAN */
1490        return 0;
1491
1492#ifdef WORDS_BIGENDIAN
1493        /* small endian floats: reverse if we're big-endian */
1494    case 'q':
1495    case 'r':
1496#else /* !WORDS_BIGENDIAN */
1497        /* native ints: reverse if we're little-endian */
1498    case 'n':
1499    case 't':
1500    case 'm':
1501        /* f: reverse if we're little-endian */
1502    case 'R':
1503#endif /* WORDS_BIGENDIAN */
1504        /* small endian ints: always reverse */
1505    case 'i':
1506    case 's':
1507    case 'w':
1508        return 1;
1509
1510#ifndef WORDS_BIGENDIAN
1511    /*
1512     * The Q and q formats need special handling to account for the unusual
1513     * byte ordering of 8-byte floats on Nokia 770 systems, which claim to be
1514     * little-endian, but also reverse word order.
1515     */
1516
1517    case 'Q':
1518        if (TclNokia770Doubles()) {
1519            return 3;
1520        }
1521        return 1;
1522    case 'q':
1523        if (TclNokia770Doubles()) {
1524            return 2;
1525        }
1526        return 0;
1527#endif
1528    }
1529
1530    Tcl_Panic("unexpected fallthrough");
1531    return 0;
1532}
1533
1534/*
1535 *----------------------------------------------------------------------
1536 *
1537 * CopyNumber --
1538 *
1539 *      This routine is called by FormatNumber and ScanNumber to copy a
1540 *      floating-point number. If required, bytes are reversed while copying.
1541 *      The behaviour is only fully defined when used with IEEE float and
1542 *      double values (guaranteed to be 4 and 8 bytes long, respectively.)
1543 *
1544 * Results:
1545 *      None
1546 *
1547 * Side effects:
1548 *      Copies length bytes
1549 *
1550 *----------------------------------------------------------------------
1551 */
1552
1553static void
1554CopyNumber(
1555    const void *from,           /* source */
1556    void *to,                   /* destination */
1557    unsigned int length,        /* Number of bytes to copy */
1558    int type)                   /* What type of thing are we copying? */
1559{
1560    switch (NeedReversing(type)) {
1561    case 0: 
1562        memcpy(to, from, length);
1563        break;
1564    case 1: {
1565        const unsigned char *fromPtr = from;
1566        unsigned char *toPtr = to;
1567
1568        switch (length) {
1569        case 4:
1570            toPtr[0] = fromPtr[3];
1571            toPtr[1] = fromPtr[2];
1572            toPtr[2] = fromPtr[1];
1573            toPtr[3] = fromPtr[0];
1574            break;
1575        case 8:
1576            toPtr[0] = fromPtr[7];
1577            toPtr[1] = fromPtr[6];
1578            toPtr[2] = fromPtr[5];
1579            toPtr[3] = fromPtr[4];
1580            toPtr[4] = fromPtr[3];
1581            toPtr[5] = fromPtr[2];
1582            toPtr[6] = fromPtr[1];
1583            toPtr[7] = fromPtr[0];
1584            break;
1585        }
1586        break;
1587    }
1588    case 2: {
1589        const unsigned char *fromPtr = from;
1590        unsigned char *toPtr = to;
1591
1592        toPtr[0] = fromPtr[4];
1593        toPtr[1] = fromPtr[5];
1594        toPtr[2] = fromPtr[6];
1595        toPtr[3] = fromPtr[7];
1596        toPtr[4] = fromPtr[0];
1597        toPtr[5] = fromPtr[1];
1598        toPtr[6] = fromPtr[2];
1599        toPtr[7] = fromPtr[3];
1600        break;
1601    }
1602    case 3: {
1603        const unsigned char *fromPtr = from;
1604        unsigned char *toPtr = to;
1605
1606        toPtr[0] = fromPtr[3];
1607        toPtr[1] = fromPtr[2];
1608        toPtr[2] = fromPtr[1];
1609        toPtr[3] = fromPtr[0];
1610        toPtr[4] = fromPtr[7];
1611        toPtr[5] = fromPtr[6];
1612        toPtr[6] = fromPtr[5];
1613        toPtr[7] = fromPtr[4];
1614        break;
1615    }
1616    }
1617}
1618
1619/*
1620 *----------------------------------------------------------------------
1621 *
1622 * FormatNumber --
1623 *
1624 *      This routine is called by Tcl_BinaryObjCmd to format a number into a
1625 *      location pointed at by cursor.
1626 *
1627 * Results:
1628 *      A standard Tcl result.
1629 *
1630 * Side effects:
1631 *      Moves the cursor to the next location to be written into.
1632 *
1633 *----------------------------------------------------------------------
1634 */
1635
1636static int
1637FormatNumber(
1638    Tcl_Interp *interp,         /* Current interpreter, used to report
1639                                 * errors. */
1640    int type,                   /* Type of number to format. */
1641    Tcl_Obj *src,               /* Number to format. */
1642    unsigned char **cursorPtr)  /* Pointer to index into destination buffer. */
1643{
1644    long value;
1645    double dvalue;
1646    Tcl_WideInt wvalue;
1647    float fvalue;
1648
1649    switch (type) {
1650    case 'd':
1651    case 'q':
1652    case 'Q':
1653        /*
1654         * Double-precision floating point values. Tcl_GetDoubleFromObj
1655         * returns TCL_ERROR for NaN, but we can check by comparing the
1656         * object's type pointer.
1657         */
1658
1659        if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
1660            if (src->typePtr != &tclDoubleType) {
1661                return TCL_ERROR;
1662            }
1663            dvalue = src->internalRep.doubleValue;
1664        }
1665        CopyNumber(&dvalue, *cursorPtr, sizeof(double), type);
1666        *cursorPtr += sizeof(double);
1667        return TCL_OK;
1668
1669    case 'f':
1670    case 'r':
1671    case 'R':
1672        /*
1673         * Single-precision floating point values. Tcl_GetDoubleFromObj
1674         * returns TCL_ERROR for NaN, but we can check by comparing the
1675         * object's type pointer.
1676         */
1677
1678        if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
1679            if (src->typePtr != &tclDoubleType) {
1680                return TCL_ERROR;
1681            }
1682            dvalue = src->internalRep.doubleValue;
1683        }
1684
1685        /*
1686         * Because some compilers will generate floating point exceptions on
1687         * an overflow cast (e.g. Borland), we restrict the values to the
1688         * valid range for float.
1689         */
1690
1691        if (fabs(dvalue) > (double)FLT_MAX) {
1692            fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
1693        } else {
1694            fvalue = (float) dvalue;
1695        }
1696        CopyNumber(&fvalue, *cursorPtr, sizeof(float), type);
1697        *cursorPtr += sizeof(float);
1698        return TCL_OK;
1699
1700        /*
1701         * 64-bit integer values.
1702         */
1703    case 'w':
1704    case 'W':
1705    case 'm':
1706        if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
1707            return TCL_ERROR;
1708        }
1709        if (NeedReversing(type)) {
1710            *(*cursorPtr)++ = (unsigned char) wvalue;
1711            *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
1712            *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
1713            *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
1714            *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
1715            *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
1716            *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
1717            *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
1718        } else {
1719            *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
1720            *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
1721            *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
1722            *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
1723            *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
1724            *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
1725            *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
1726            *(*cursorPtr)++ = (unsigned char) wvalue;
1727        }
1728        return TCL_OK;
1729
1730        /*
1731         * 32-bit integer values.
1732         */
1733    case 'i':
1734    case 'I':
1735    case 'n':
1736        if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
1737            return TCL_ERROR;
1738        }
1739        if (NeedReversing(type)) {
1740            *(*cursorPtr)++ = (unsigned char) value;
1741            *(*cursorPtr)++ = (unsigned char) (value >> 8);
1742            *(*cursorPtr)++ = (unsigned char) (value >> 16);
1743            *(*cursorPtr)++ = (unsigned char) (value >> 24);
1744        } else {
1745            *(*cursorPtr)++ = (unsigned char) (value >> 24);
1746            *(*cursorPtr)++ = (unsigned char) (value >> 16);
1747            *(*cursorPtr)++ = (unsigned char) (value >> 8);
1748            *(*cursorPtr)++ = (unsigned char) value;
1749        }
1750        return TCL_OK;
1751
1752        /*
1753         * 16-bit integer values.
1754         */
1755    case 's':
1756    case 'S':
1757    case 't':
1758        if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
1759            return TCL_ERROR;
1760        }
1761        if (NeedReversing(type)) {
1762            *(*cursorPtr)++ = (unsigned char) value;
1763            *(*cursorPtr)++ = (unsigned char) (value >> 8);
1764        } else {
1765            *(*cursorPtr)++ = (unsigned char) (value >> 8);
1766            *(*cursorPtr)++ = (unsigned char) value;
1767        }
1768        return TCL_OK;
1769
1770        /*
1771         * 8-bit integer values.
1772         */
1773    case 'c':
1774        if (TclGetLongFromObj(interp, src, &value) != TCL_OK) {
1775            return TCL_ERROR;
1776        }
1777        *(*cursorPtr)++ = (unsigned char) value;
1778        return TCL_OK;
1779
1780    default:
1781        Tcl_Panic("unexpected fallthrough");
1782        return TCL_ERROR;
1783    }
1784}
1785
1786/*
1787 *----------------------------------------------------------------------
1788 *
1789 * ScanNumber --
1790 *
1791 *      This routine is called by Tcl_BinaryObjCmd to scan a number out of a
1792 *      buffer.
1793 *
1794 * Results:
1795 *      Returns a newly created object containing the scanned number. This
1796 *      object has a ref count of zero.
1797 *
1798 * Side effects:
1799 *      Might reuse an object in the number cache, place a new object in the
1800 *      cache, or delete the cache and set the reference to it (itself passed
1801 *      in by reference) to NULL.
1802 *
1803 *----------------------------------------------------------------------
1804 */
1805
1806static Tcl_Obj *
1807ScanNumber(
1808    unsigned char *buffer,      /* Buffer to scan number from. */
1809    int type,                   /* Format character from "binary scan" */
1810    int flags,                  /* Format field flags */
1811    Tcl_HashTable **numberCachePtrPtr)
1812                                /* Place to look for cache of scanned
1813                                 * value objects, or NULL if too many
1814                                 * different numbers have been scanned. */
1815{
1816    long value;
1817    float fvalue;
1818    double dvalue;
1819    Tcl_WideUInt uwvalue;
1820
1821    /*
1822     * We cannot rely on the compiler to properly sign extend integer values
1823     * when we cast from smaller values to larger values because we don't know
1824     * the exact size of the integer types. So, we have to handle sign
1825     * extension explicitly by checking the high bit and padding with 1's as
1826     * needed. This practice is disabled if the BINARY_UNSIGNED flag is set.
1827     */
1828
1829    switch (type) {
1830    case 'c':
1831        /*
1832         * Characters need special handling. We want to produce a signed
1833         * result, but on some platforms (such as AIX) chars are unsigned. To
1834         * deal with this, check for a value that should be negative but
1835         * isn't.
1836         */
1837
1838        value = buffer[0];
1839        if (!(flags & BINARY_UNSIGNED)) {
1840            if (value & 0x80) {
1841                value |= -0x100;
1842            }
1843        }
1844        goto returnNumericObject;
1845
1846        /*
1847         * 16-bit numeric values. We need the sign extension trick (see above)
1848         * here as well.
1849         */
1850
1851    case 's':
1852    case 'S':
1853    case 't':
1854        if (NeedReversing(type)) {
1855            value = (long) (buffer[0] + (buffer[1] << 8));
1856        } else {
1857            value = (long) (buffer[1] + (buffer[0] << 8));
1858        }
1859        if (!(flags & BINARY_UNSIGNED)) {
1860            if (value & 0x8000) {
1861                value |= -0x10000;
1862            }
1863        }
1864        goto returnNumericObject;
1865
1866        /*
1867         * 32-bit numeric values.
1868         */
1869
1870    case 'i':
1871    case 'I':
1872    case 'n':
1873        if (NeedReversing(type)) {
1874            value = (long) (buffer[0]
1875                    + (buffer[1] << 8)
1876                    + (buffer[2] << 16)
1877                    + (((long)buffer[3]) << 24));
1878        } else {
1879            value = (long) (buffer[3]
1880                    + (buffer[2] << 8)
1881                    + (buffer[1] << 16)
1882                    + (((long)buffer[0]) << 24));
1883        }
1884
1885        /*
1886         * Check to see if the value was sign extended properly on systems
1887         * where an int is more than 32-bits.
1888         * We avoid caching unsigned integers as we cannot distinguish between
1889         * 32bit signed and unsigned in the hash (short and char are ok).
1890         */
1891
1892        if (flags & BINARY_UNSIGNED) {
1893            return Tcl_NewWideIntObj((Tcl_WideInt)(unsigned long)value);
1894        }
1895        if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
1896            value -= (((unsigned int)1)<<31);
1897            value -= (((unsigned int)1)<<31);
1898        }
1899
1900    returnNumericObject:
1901        if (*numberCachePtrPtr == NULL) {
1902            return Tcl_NewLongObj(value);
1903        } else {
1904            register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
1905            register Tcl_HashEntry *hPtr;
1906            int isNew;
1907
1908            hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
1909            if (!isNew) {
1910                return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
1911            }
1912            if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) {
1913                register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
1914
1915                Tcl_IncrRefCount(objPtr);
1916                Tcl_SetHashValue(hPtr, (ClientData) objPtr);
1917                return objPtr;
1918            }
1919
1920            /*
1921             * We've overflowed the cache! Someone's parsing a LOT of varied
1922             * binary data in a single call! Bail out by switching back to the
1923             * old behaviour for the rest of the scan.
1924             *
1925             * Note that anyone just using the 'c' conversion (for bytes)
1926             * cannot trigger this.
1927             */
1928
1929            DeleteScanNumberCache(tablePtr);
1930            *numberCachePtrPtr = NULL;
1931            return Tcl_NewLongObj(value);
1932        }
1933
1934        /*
1935         * Do not cache wide (64-bit) values; they are already too large to
1936         * use as keys.
1937         */
1938
1939    case 'w':
1940    case 'W':
1941    case 'm':
1942        if (NeedReversing(type)) {
1943            uwvalue = ((Tcl_WideUInt) buffer[0])
1944                    | (((Tcl_WideUInt) buffer[1]) << 8)
1945                    | (((Tcl_WideUInt) buffer[2]) << 16)
1946                    | (((Tcl_WideUInt) buffer[3]) << 24)
1947                    | (((Tcl_WideUInt) buffer[4]) << 32)
1948                    | (((Tcl_WideUInt) buffer[5]) << 40)
1949                    | (((Tcl_WideUInt) buffer[6]) << 48)
1950                    | (((Tcl_WideUInt) buffer[7]) << 56);
1951        } else {
1952            uwvalue = ((Tcl_WideUInt) buffer[7])
1953                    | (((Tcl_WideUInt) buffer[6]) << 8)
1954                    | (((Tcl_WideUInt) buffer[5]) << 16)
1955                    | (((Tcl_WideUInt) buffer[4]) << 24)
1956                    | (((Tcl_WideUInt) buffer[3]) << 32)
1957                    | (((Tcl_WideUInt) buffer[2]) << 40)
1958                    | (((Tcl_WideUInt) buffer[1]) << 48)
1959                    | (((Tcl_WideUInt) buffer[0]) << 56);
1960        }
1961        if (flags & BINARY_UNSIGNED) {
1962            Tcl_Obj *bigObj = NULL;
1963            mp_int big;
1964
1965            TclBNInitBignumFromWideUInt(&big, uwvalue);
1966            bigObj = Tcl_NewBignumObj(&big);
1967            return bigObj;
1968        }
1969        return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
1970
1971        /*
1972         * Do not cache double values; they are already too large to use as
1973         * keys and the values stored are utterly incompatible with the
1974         * integer part of the cache.
1975         */
1976
1977        /*
1978         * 32-bit IEEE single-precision floating point.
1979         */
1980
1981    case 'f':
1982    case 'R':
1983    case 'r':
1984        CopyNumber(buffer, &fvalue, sizeof(float), type);
1985        return Tcl_NewDoubleObj(fvalue);
1986
1987        /*
1988         * 64-bit IEEE double-precision floating point.
1989         */
1990
1991    case 'd':
1992    case 'Q':
1993    case 'q':
1994        CopyNumber(buffer, &dvalue, sizeof(double), type);
1995        return Tcl_NewDoubleObj(dvalue);
1996    }
1997    return NULL;
1998}
1999
2000/*
2001 *----------------------------------------------------------------------
2002 *
2003 * DeleteScanNumberCache --
2004 *
2005 *      Deletes the hash table acting as a scan number cache.
2006 *
2007 * Results:
2008 *      None
2009 *
2010 * Side effects:
2011 *      Decrements the reference counts of the objects in the cache.
2012 *
2013 *----------------------------------------------------------------------
2014 */
2015
2016static void
2017DeleteScanNumberCache(
2018    Tcl_HashTable *numberCachePtr)
2019                                /* Pointer to the hash table, or NULL (when
2020                                 * the cache has already been deleted due to
2021                                 * overflow.) */
2022{
2023    Tcl_HashEntry *hEntry;
2024    Tcl_HashSearch search;
2025
2026    if (numberCachePtr == NULL) {
2027        return;
2028    }
2029
2030    hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
2031    while (hEntry != NULL) {
2032        register Tcl_Obj *value = Tcl_GetHashValue(hEntry);
2033
2034        if (value != NULL) {
2035            Tcl_DecrRefCount(value);
2036        }
2037        hEntry = Tcl_NextHashEntry(&search);
2038    }
2039    Tcl_DeleteHashTable(numberCachePtr);
2040}
2041
2042/*
2043 * Local Variables:
2044 * mode: c
2045 * c-basic-offset: 4
2046 * fill-column: 78
2047 * End:
2048 */
Note: See TracBrowser for help on using the repository browser.