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 | |
---|
59 | static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, |
---|
60 | Tcl_Obj *copyPtr); |
---|
61 | static int FormatNumber(Tcl_Interp *interp, int type, |
---|
62 | Tcl_Obj *src, unsigned char **cursorPtr); |
---|
63 | static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); |
---|
64 | static int GetFormatSpec(char **formatPtr, char *cmdPtr, |
---|
65 | int *countPtr, int *flagsPtr); |
---|
66 | static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, |
---|
67 | int flags, Tcl_HashTable **numberCachePtr); |
---|
68 | static int SetByteArrayFromAny(Tcl_Interp *interp, |
---|
69 | Tcl_Obj *objPtr); |
---|
70 | static void UpdateStringOfByteArray(Tcl_Obj *listPtr); |
---|
71 | static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); |
---|
72 | static int NeedReversing(int format); |
---|
73 | static 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 | |
---|
101 | Tcl_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 | |
---|
116 | typedef 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 | |
---|
155 | Tcl_Obj * |
---|
156 | Tcl_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 | |
---|
167 | Tcl_Obj * |
---|
168 | Tcl_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 | |
---|
209 | Tcl_Obj * |
---|
210 | Tcl_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 | |
---|
229 | Tcl_Obj * |
---|
230 | Tcl_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 | |
---|
262 | void |
---|
263 | Tcl_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 | |
---|
305 | unsigned char * |
---|
306 | Tcl_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 | |
---|
346 | unsigned char * |
---|
347 | Tcl_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 | |
---|
388 | static int |
---|
389 | SetByteArrayFromAny( |
---|
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 | |
---|
436 | static void |
---|
437 | FreeByteArrayInternalRep( |
---|
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 | |
---|
460 | static void |
---|
461 | DupByteArrayInternalRep( |
---|
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 | |
---|
502 | static void |
---|
503 | UpdateStringOfByteArray( |
---|
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 | |
---|
558 | int |
---|
559 | Tcl_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 | |
---|
1395 | static int |
---|
1396 | GetFormatSpec( |
---|
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 | |
---|
1466 | static int |
---|
1467 | NeedReversing( |
---|
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 | |
---|
1553 | static void |
---|
1554 | CopyNumber( |
---|
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 | |
---|
1636 | static int |
---|
1637 | FormatNumber( |
---|
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 | |
---|
1806 | static Tcl_Obj * |
---|
1807 | ScanNumber( |
---|
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 | |
---|
2016 | static void |
---|
2017 | DeleteScanNumberCache( |
---|
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 | */ |
---|