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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25