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

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

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25