os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclBinary.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclBinary.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,1766 @@
1.4 +/*
1.5 + * tclBinary.c --
1.6 + *
1.7 + * This file contains the implementation of the "binary" Tcl built-in
1.8 + * command and the Tcl binary data object.
1.9 + *
1.10 + * Copyright (c) 1997 by Sun Microsystems, Inc.
1.11 + * Copyright (c) 1998-1999 by Scriptics Corporation.
1.12 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.13 + *
1.14 + * See the file "license.terms" for information on usage and redistribution
1.15 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 + *
1.17 + * RCS: @(#) $Id: tclBinary.c,v 1.13.2.4 2005/10/23 22:01:29 msofer Exp $
1.18 + */
1.19 +
1.20 +#include "tclInt.h"
1.21 +#include "tclPort.h"
1.22 +#include <math.h>
1.23 +
1.24 +/*
1.25 + * The following constants are used by GetFormatSpec to indicate various
1.26 + * special conditions in the parsing of a format specifier.
1.27 + */
1.28 +
1.29 +#define BINARY_ALL -1 /* Use all elements in the argument. */
1.30 +#define BINARY_NOCOUNT -2 /* No count was specified in format. */
1.31 +
1.32 +/*
1.33 + * The following defines the maximum number of different (integer)
1.34 + * numbers placed in the object cache by 'binary scan' before it bails
1.35 + * out and switches back to Plan A (creating a new object for each
1.36 + * value.) Theoretically, it would be possible to keep the cache
1.37 + * about for the values that are already in it, but that makes the
1.38 + * code slower in practise when overflow happens, and makes little
1.39 + * odds the rest of the time (as measured on my machine.) It is also
1.40 + * slower (on the sample I tried at least) to grow the cache to hold
1.41 + * all items we might want to put in it; presumably the extra cost of
1.42 + * managing the memory for the enlarged table outweighs the benefit
1.43 + * from allocating fewer objects. This is probably because as the
1.44 + * number of objects increases, the likelihood of reuse of any
1.45 + * particular one drops, and there is very little gain from larger
1.46 + * maximum cache sizes (the value below is chosen to allow caching to
1.47 + * work in full with conversion of bytes.) - DKF
1.48 + */
1.49 +
1.50 +#define BINARY_SCAN_MAX_CACHE 260
1.51 +
1.52 +/*
1.53 + * Prototypes for local procedures defined in this file:
1.54 + */
1.55 +
1.56 +static void DupByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
1.57 + Tcl_Obj *copyPtr));
1.58 +static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
1.59 + Tcl_Obj *src, unsigned char **cursorPtr));
1.60 +static void CopyNumber _ANSI_ARGS_((CONST VOID *from, VOID *to,
1.61 + unsigned int length));
1.62 +static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr));
1.63 +static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
1.64 + char *cmdPtr, int *countPtr));
1.65 +static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer,
1.66 + int type, Tcl_HashTable **numberCachePtr));
1.67 +static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.68 + Tcl_Obj *objPtr));
1.69 +static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
1.70 +static void DeleteScanNumberCache _ANSI_ARGS_((
1.71 + Tcl_HashTable *numberCachePtr));
1.72 +
1.73 +/*
1.74 + * The following object type represents an array of bytes. An array of
1.75 + * bytes is not equivalent to an internationalized string. Conceptually, a
1.76 + * string is an array of 16-bit quantities organized as a sequence of properly
1.77 + * formed UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
1.78 + * Accessor functions are provided to convert a ByteArray to a String or a
1.79 + * String to a ByteArray. Two or more consecutive bytes in an array of bytes
1.80 + * may look like a single UTF-8 character if the array is casually treated as
1.81 + * a string. But obtaining the String from a ByteArray is guaranteed to
1.82 + * produced properly formed UTF-8 sequences so that there is a one-to-one
1.83 + * map between bytes and characters.
1.84 + *
1.85 + * Converting a ByteArray to a String proceeds by casting each byte in the
1.86 + * array to a 16-bit quantity, treating that number as a Unicode character,
1.87 + * and storing the UTF-8 version of that Unicode character in the String.
1.88 + * For ByteArrays consisting entirely of values 1..127, the corresponding
1.89 + * String representation is the same as the ByteArray representation.
1.90 + *
1.91 + * Converting a String to a ByteArray proceeds by getting the Unicode
1.92 + * representation of each character in the String, casting it to a
1.93 + * byte by truncating the upper 8 bits, and then storing the byte in the
1.94 + * ByteArray. Converting from ByteArray to String and back to ByteArray
1.95 + * is not lossy, but converting an arbitrary String to a ByteArray may be.
1.96 + */
1.97 +
1.98 +Tcl_ObjType tclByteArrayType = {
1.99 + "bytearray",
1.100 + FreeByteArrayInternalRep,
1.101 + DupByteArrayInternalRep,
1.102 + UpdateStringOfByteArray,
1.103 + SetByteArrayFromAny
1.104 +};
1.105 +
1.106 +/*
1.107 + * The following structure is the internal rep for a ByteArray object.
1.108 + * Keeps track of how much memory has been used and how much has been
1.109 + * allocated for the byte array to enable growing and shrinking of the
1.110 + * ByteArray object with fewer mallocs.
1.111 + */
1.112 +
1.113 +typedef struct ByteArray {
1.114 + int used; /* The number of bytes used in the byte
1.115 + * array. */
1.116 + int allocated; /* The amount of space actually allocated
1.117 + * minus 1 byte. */
1.118 + unsigned char bytes[4]; /* The array of bytes. The actual size of
1.119 + * this field depends on the 'allocated' field
1.120 + * above. */
1.121 +} ByteArray;
1.122 +
1.123 +#define BYTEARRAY_SIZE(len) \
1.124 + ((unsigned) (sizeof(ByteArray) - 4 + (len)))
1.125 +#define GET_BYTEARRAY(objPtr) \
1.126 + ((ByteArray *) (objPtr)->internalRep.otherValuePtr)
1.127 +#define SET_BYTEARRAY(objPtr, baPtr) \
1.128 + (objPtr)->internalRep.otherValuePtr = (VOID *) (baPtr)
1.129 +
1.130 +
1.131 +/*
1.132 + *---------------------------------------------------------------------------
1.133 + *
1.134 + * Tcl_NewByteArrayObj --
1.135 + *
1.136 + * This procedure is creates a new ByteArray object and initializes
1.137 + * it from the given array of bytes.
1.138 + *
1.139 + * Results:
1.140 + * The newly create object is returned. This object will have no
1.141 + * initial string representation. The returned object has a ref count
1.142 + * of 0.
1.143 + *
1.144 + * Side effects:
1.145 + * Memory allocated for new object and copy of byte array argument.
1.146 + *
1.147 + *---------------------------------------------------------------------------
1.148 + */
1.149 +
1.150 +#ifdef TCL_MEM_DEBUG
1.151 +#undef Tcl_NewByteArrayObj
1.152 +
1.153 +
1.154 +EXPORT_C Tcl_Obj *
1.155 +Tcl_NewByteArrayObj(bytes, length)
1.156 + CONST unsigned char *bytes; /* The array of bytes used to initialize
1.157 + * the new object. */
1.158 + int length; /* Length of the array of bytes, which must
1.159 + * be >= 0. */
1.160 +{
1.161 + return Tcl_DbNewByteArrayObj(bytes, length, "unknown", 0);
1.162 +}
1.163 +
1.164 +#else /* if not TCL_MEM_DEBUG */
1.165 +
1.166 +EXPORT_C Tcl_Obj *
1.167 +Tcl_NewByteArrayObj(bytes, length)
1.168 + CONST unsigned char *bytes; /* The array of bytes used to initialize
1.169 + * the new object. */
1.170 + int length; /* Length of the array of bytes, which must
1.171 + * be >= 0. */
1.172 +{
1.173 + Tcl_Obj *objPtr;
1.174 +
1.175 + TclNewObj(objPtr);
1.176 + Tcl_SetByteArrayObj(objPtr, bytes, length);
1.177 + return objPtr;
1.178 +}
1.179 +#endif /* TCL_MEM_DEBUG */
1.180 +
1.181 +/*
1.182 + *---------------------------------------------------------------------------
1.183 + *
1.184 + * Tcl_DbNewByteArrayObj --
1.185 + *
1.186 + * This procedure is normally called when debugging: i.e., when
1.187 + * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj
1.188 + * above except that it calls Tcl_DbCkalloc directly with the file name
1.189 + * and line number from its caller. This simplifies debugging since then
1.190 + * the [memory active] command will report the correct file name and line
1.191 + * number when reporting objects that haven't been freed.
1.192 + *
1.193 + * When TCL_MEM_DEBUG is not defined, this procedure just returns the
1.194 + * result of calling Tcl_NewByteArrayObj.
1.195 + *
1.196 + * Results:
1.197 + * The newly create object is returned. This object will have no
1.198 + * initial string representation. The returned object has a ref count
1.199 + * of 0.
1.200 + *
1.201 + * Side effects:
1.202 + * Memory allocated for new object and copy of byte array argument.
1.203 + *
1.204 + *---------------------------------------------------------------------------
1.205 + */
1.206 +
1.207 +#ifdef TCL_MEM_DEBUG
1.208 +
1.209 +EXPORT_C Tcl_Obj *
1.210 +Tcl_DbNewByteArrayObj(bytes, length, file, line)
1.211 + CONST unsigned char *bytes; /* The array of bytes used to initialize
1.212 + * the new object. */
1.213 + int length; /* Length of the array of bytes, which must
1.214 + * be >= 0. */
1.215 + CONST char *file; /* The name of the source file calling this
1.216 + * procedure; used for debugging. */
1.217 + int line; /* Line number in the source file; used
1.218 + * for debugging. */
1.219 +{
1.220 + Tcl_Obj *objPtr;
1.221 +
1.222 + TclDbNewObj(objPtr, file, line);
1.223 + Tcl_SetByteArrayObj(objPtr, bytes, length);
1.224 + return objPtr;
1.225 +}
1.226 +
1.227 +#else /* if not TCL_MEM_DEBUG */
1.228 +
1.229 +EXPORT_C Tcl_Obj *
1.230 +Tcl_DbNewByteArrayObj(bytes, length, file, line)
1.231 + CONST unsigned char *bytes; /* The array of bytes used to initialize
1.232 + * the new object. */
1.233 + int length; /* Length of the array of bytes, which must
1.234 + * be >= 0. */
1.235 + CONST char *file; /* The name of the source file calling this
1.236 + * procedure; used for debugging. */
1.237 + int line; /* Line number in the source file; used
1.238 + * for debugging. */
1.239 +{
1.240 + return Tcl_NewByteArrayObj(bytes, length);
1.241 +}
1.242 +#endif /* TCL_MEM_DEBUG */
1.243 +
1.244 +/*
1.245 + *---------------------------------------------------------------------------
1.246 + *
1.247 + * Tcl_SetByteArrayObj --
1.248 + *
1.249 + * Modify an object to be a ByteArray object and to have the specified
1.250 + * array of bytes as its value.
1.251 + *
1.252 + * Results:
1.253 + * None.
1.254 + *
1.255 + * Side effects:
1.256 + * The object's old string rep and internal rep is freed.
1.257 + * Memory allocated for copy of byte array argument.
1.258 + *
1.259 + *----------------------------------------------------------------------
1.260 + */
1.261 +
1.262 +EXPORT_C void
1.263 +Tcl_SetByteArrayObj(objPtr, bytes, length)
1.264 + Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */
1.265 + CONST unsigned char *bytes; /* The array of bytes to use as the new
1.266 + * value. */
1.267 + int length; /* Length of the array of bytes, which must
1.268 + * be >= 0. */
1.269 +{
1.270 + Tcl_ObjType *typePtr;
1.271 + ByteArray *byteArrayPtr;
1.272 +
1.273 + if (Tcl_IsShared(objPtr)) {
1.274 + panic("Tcl_SetByteArrayObj called with shared object");
1.275 + }
1.276 + typePtr = objPtr->typePtr;
1.277 + if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
1.278 + (*typePtr->freeIntRepProc)(objPtr);
1.279 + }
1.280 + Tcl_InvalidateStringRep(objPtr);
1.281 +
1.282 + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
1.283 + byteArrayPtr->used = length;
1.284 + byteArrayPtr->allocated = length;
1.285 + memcpy((VOID *) byteArrayPtr->bytes, (VOID *) bytes, (size_t) length);
1.286 +
1.287 + objPtr->typePtr = &tclByteArrayType;
1.288 + SET_BYTEARRAY(objPtr, byteArrayPtr);
1.289 +}
1.290 +
1.291 +/*
1.292 + *----------------------------------------------------------------------
1.293 + *
1.294 + * Tcl_GetByteArrayFromObj --
1.295 + *
1.296 + * Attempt to get the array of bytes from the Tcl object. If the
1.297 + * object is not already a ByteArray object, an attempt will be
1.298 + * made to convert it to one.
1.299 + *
1.300 + * Results:
1.301 + * Pointer to array of bytes representing the ByteArray object.
1.302 + *
1.303 + * Side effects:
1.304 + * Frees old internal rep. Allocates memory for new internal rep.
1.305 + *
1.306 + *----------------------------------------------------------------------
1.307 + */
1.308 +
1.309 +EXPORT_C unsigned char *
1.310 +Tcl_GetByteArrayFromObj(objPtr, lengthPtr)
1.311 + Tcl_Obj *objPtr; /* The ByteArray object. */
1.312 + int *lengthPtr; /* If non-NULL, filled with length of the
1.313 + * array of bytes in the ByteArray object. */
1.314 +{
1.315 + ByteArray *baPtr;
1.316 +
1.317 + SetByteArrayFromAny(NULL, objPtr);
1.318 + baPtr = GET_BYTEARRAY(objPtr);
1.319 +
1.320 + if (lengthPtr != NULL) {
1.321 + *lengthPtr = baPtr->used;
1.322 + }
1.323 + return (unsigned char *) baPtr->bytes;
1.324 +}
1.325 +
1.326 +/*
1.327 + *----------------------------------------------------------------------
1.328 + *
1.329 + * Tcl_SetByteArrayLength --
1.330 + *
1.331 + * This procedure changes the length of the byte array for this
1.332 + * object. Once the caller has set the length of the array, it
1.333 + * is acceptable to directly modify the bytes in the array up until
1.334 + * Tcl_GetStringFromObj() has been called on this object.
1.335 + *
1.336 + * Results:
1.337 + * The new byte array of the specified length.
1.338 + *
1.339 + * Side effects:
1.340 + * Allocates enough memory for an array of bytes of the requested
1.341 + * size. When growing the array, the old array is copied to the
1.342 + * new array; new bytes are undefined. When shrinking, the
1.343 + * old array is truncated to the specified length.
1.344 + *
1.345 + *---------------------------------------------------------------------------
1.346 + */
1.347 +
1.348 +EXPORT_C unsigned char *
1.349 +Tcl_SetByteArrayLength(objPtr, length)
1.350 + Tcl_Obj *objPtr; /* The ByteArray object. */
1.351 + int length; /* New length for internal byte array. */
1.352 +{
1.353 + ByteArray *byteArrayPtr, *newByteArrayPtr;
1.354 +
1.355 + if (Tcl_IsShared(objPtr)) {
1.356 + panic("Tcl_SetObjLength called with shared object");
1.357 + }
1.358 + if (objPtr->typePtr != &tclByteArrayType) {
1.359 + SetByteArrayFromAny(NULL, objPtr);
1.360 + }
1.361 +
1.362 + byteArrayPtr = GET_BYTEARRAY(objPtr);
1.363 + if (length > byteArrayPtr->allocated) {
1.364 + newByteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
1.365 + newByteArrayPtr->used = length;
1.366 + newByteArrayPtr->allocated = length;
1.367 + memcpy((VOID *) newByteArrayPtr->bytes,
1.368 + (VOID *) byteArrayPtr->bytes, (size_t) byteArrayPtr->used);
1.369 + ckfree((char *) byteArrayPtr);
1.370 + byteArrayPtr = newByteArrayPtr;
1.371 + SET_BYTEARRAY(objPtr, byteArrayPtr);
1.372 + }
1.373 + Tcl_InvalidateStringRep(objPtr);
1.374 + byteArrayPtr->used = length;
1.375 + return byteArrayPtr->bytes;
1.376 +}
1.377 +
1.378 +/*
1.379 + *---------------------------------------------------------------------------
1.380 + *
1.381 + * SetByteArrayFromAny --
1.382 + *
1.383 + * Generate the ByteArray internal rep from the string rep.
1.384 + *
1.385 + * Results:
1.386 + * The return value is always TCL_OK.
1.387 + *
1.388 + * Side effects:
1.389 + * A ByteArray object is stored as the internal rep of objPtr.
1.390 + *
1.391 + *---------------------------------------------------------------------------
1.392 + */
1.393 +
1.394 +static int
1.395 +SetByteArrayFromAny(interp, objPtr)
1.396 + Tcl_Interp *interp; /* Not used. */
1.397 + Tcl_Obj *objPtr; /* The object to convert to type ByteArray. */
1.398 +{
1.399 + Tcl_ObjType *typePtr;
1.400 + int length;
1.401 + char *src, *srcEnd;
1.402 + unsigned char *dst;
1.403 + ByteArray *byteArrayPtr;
1.404 + Tcl_UniChar ch;
1.405 +
1.406 + typePtr = objPtr->typePtr;
1.407 + if (typePtr != &tclByteArrayType) {
1.408 + src = Tcl_GetStringFromObj(objPtr, &length);
1.409 + srcEnd = src + length;
1.410 +
1.411 + byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
1.412 + for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
1.413 + src += Tcl_UtfToUniChar(src, &ch);
1.414 + *dst++ = (unsigned char) ch;
1.415 + }
1.416 +
1.417 + byteArrayPtr->used = dst - byteArrayPtr->bytes;
1.418 + byteArrayPtr->allocated = length;
1.419 +
1.420 + if ((typePtr != NULL) && (typePtr->freeIntRepProc) != NULL) {
1.421 + (*typePtr->freeIntRepProc)(objPtr);
1.422 + }
1.423 + objPtr->typePtr = &tclByteArrayType;
1.424 + SET_BYTEARRAY(objPtr, byteArrayPtr);
1.425 + }
1.426 + return TCL_OK;
1.427 +}
1.428 +
1.429 +/*
1.430 + *----------------------------------------------------------------------
1.431 + *
1.432 + * FreeByteArrayInternalRep --
1.433 + *
1.434 + * Deallocate the storage associated with a ByteArray data object's
1.435 + * internal representation.
1.436 + *
1.437 + * Results:
1.438 + * None.
1.439 + *
1.440 + * Side effects:
1.441 + * Frees memory.
1.442 + *
1.443 + *----------------------------------------------------------------------
1.444 + */
1.445 +
1.446 +static void
1.447 +FreeByteArrayInternalRep(objPtr)
1.448 + Tcl_Obj *objPtr; /* Object with internal rep to free. */
1.449 +{
1.450 + ckfree((char *) GET_BYTEARRAY(objPtr));
1.451 +}
1.452 +
1.453 +/*
1.454 + *---------------------------------------------------------------------------
1.455 + *
1.456 + * DupByteArrayInternalRep --
1.457 + *
1.458 + * Initialize the internal representation of a ByteArray Tcl_Obj
1.459 + * to a copy of the internal representation of an existing ByteArray
1.460 + * object.
1.461 + *
1.462 + * Results:
1.463 + * None.
1.464 + *
1.465 + * Side effects:
1.466 + * Allocates memory.
1.467 + *
1.468 + *---------------------------------------------------------------------------
1.469 + */
1.470 +
1.471 +static void
1.472 +DupByteArrayInternalRep(srcPtr, copyPtr)
1.473 + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
1.474 + Tcl_Obj *copyPtr; /* Object with internal rep to set. */
1.475 +{
1.476 + int length;
1.477 + ByteArray *srcArrayPtr, *copyArrayPtr;
1.478 +
1.479 + srcArrayPtr = GET_BYTEARRAY(srcPtr);
1.480 + length = srcArrayPtr->used;
1.481 +
1.482 + copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
1.483 + copyArrayPtr->used = length;
1.484 + copyArrayPtr->allocated = length;
1.485 + memcpy((VOID *) copyArrayPtr->bytes, (VOID *) srcArrayPtr->bytes,
1.486 + (size_t) length);
1.487 + SET_BYTEARRAY(copyPtr, copyArrayPtr);
1.488 +
1.489 + copyPtr->typePtr = &tclByteArrayType;
1.490 +}
1.491 +
1.492 +/*
1.493 + *---------------------------------------------------------------------------
1.494 + *
1.495 + * UpdateStringOfByteArray --
1.496 + *
1.497 + * Update the string representation for a ByteArray data object.
1.498 + * Note: This procedure does not invalidate an existing old string rep
1.499 + * so storage will be lost if this has not already been done.
1.500 + *
1.501 + * Results:
1.502 + * None.
1.503 + *
1.504 + * Side effects:
1.505 + * The object's string is set to a valid string that results from
1.506 + * the ByteArray-to-string conversion.
1.507 + *
1.508 + * The object becomes a string object -- the internal rep is
1.509 + * discarded and the typePtr becomes NULL.
1.510 + *
1.511 + *---------------------------------------------------------------------------
1.512 + */
1.513 +
1.514 +static void
1.515 +UpdateStringOfByteArray(objPtr)
1.516 + Tcl_Obj *objPtr; /* ByteArray object whose string rep to
1.517 + * update. */
1.518 +{
1.519 + int i, length, size;
1.520 + unsigned char *src;
1.521 + char *dst;
1.522 + ByteArray *byteArrayPtr;
1.523 +
1.524 + byteArrayPtr = GET_BYTEARRAY(objPtr);
1.525 + src = byteArrayPtr->bytes;
1.526 + length = byteArrayPtr->used;
1.527 +
1.528 + /*
1.529 + * How much space will string rep need?
1.530 + */
1.531 +
1.532 + size = length;
1.533 + for (i = 0; i < length; i++) {
1.534 + if ((src[i] == 0) || (src[i] > 127)) {
1.535 + size++;
1.536 + }
1.537 + }
1.538 +
1.539 + dst = (char *) ckalloc((unsigned) (size + 1));
1.540 + objPtr->bytes = dst;
1.541 + objPtr->length = size;
1.542 +
1.543 + if (size == length) {
1.544 + memcpy((VOID *) dst, (VOID *) src, (size_t) size);
1.545 + dst[size] = '\0';
1.546 + } else {
1.547 + for (i = 0; i < length; i++) {
1.548 + dst += Tcl_UniCharToUtf(src[i], dst);
1.549 + }
1.550 + *dst = '\0';
1.551 + }
1.552 +}
1.553 +
1.554 +/*
1.555 + *----------------------------------------------------------------------
1.556 + *
1.557 + * Tcl_BinaryObjCmd --
1.558 + *
1.559 + * This procedure implements the "binary" Tcl command.
1.560 + *
1.561 + * Results:
1.562 + * A standard Tcl result.
1.563 + *
1.564 + * Side effects:
1.565 + * See the user documentation.
1.566 + *
1.567 + *----------------------------------------------------------------------
1.568 + */
1.569 +
1.570 +int
1.571 +Tcl_BinaryObjCmd(dummy, interp, objc, objv)
1.572 + ClientData dummy; /* Not used. */
1.573 + Tcl_Interp *interp; /* Current interpreter. */
1.574 + int objc; /* Number of arguments. */
1.575 + Tcl_Obj *CONST objv[]; /* Argument objects. */
1.576 +{
1.577 + int arg; /* Index of next argument to consume. */
1.578 + int value = 0; /* Current integer value to be packed.
1.579 + * Initialized to avoid compiler warning. */
1.580 + char cmd; /* Current format character. */
1.581 + int count; /* Count associated with current format
1.582 + * character. */
1.583 + char *format; /* Pointer to current position in format
1.584 + * string. */
1.585 + Tcl_Obj *resultPtr; /* Object holding result buffer. */
1.586 + unsigned char *buffer; /* Start of result buffer. */
1.587 + unsigned char *cursor; /* Current position within result buffer. */
1.588 + unsigned char *maxPos; /* Greatest position within result buffer that
1.589 + * cursor has visited.*/
1.590 + char *errorString, *errorValue, *str;
1.591 + int offset, size, length, index;
1.592 + static CONST char *options[] = {
1.593 + "format", "scan", NULL
1.594 + };
1.595 + enum options {
1.596 + BINARY_FORMAT, BINARY_SCAN
1.597 + };
1.598 +
1.599 + if (objc < 2) {
1.600 + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
1.601 + return TCL_ERROR;
1.602 + }
1.603 +
1.604 + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0,
1.605 + &index) != TCL_OK) {
1.606 + return TCL_ERROR;
1.607 + }
1.608 +
1.609 + switch ((enum options) index) {
1.610 + case BINARY_FORMAT: {
1.611 + if (objc < 3) {
1.612 + Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
1.613 + return TCL_ERROR;
1.614 + }
1.615 +
1.616 + /*
1.617 + * To avoid copying the data, we format the string in two passes.
1.618 + * The first pass computes the size of the output buffer. The
1.619 + * second pass places the formatted data into the buffer.
1.620 + */
1.621 +
1.622 + format = Tcl_GetString(objv[2]);
1.623 + arg = 3;
1.624 + offset = 0;
1.625 + length = 0;
1.626 + while (*format != '\0') {
1.627 + str = format;
1.628 + if (!GetFormatSpec(&format, &cmd, &count)) {
1.629 + break;
1.630 + }
1.631 + switch (cmd) {
1.632 + case 'a':
1.633 + case 'A':
1.634 + case 'b':
1.635 + case 'B':
1.636 + case 'h':
1.637 + case 'H': {
1.638 + /*
1.639 + * For string-type specifiers, the count corresponds
1.640 + * to the number of bytes in a single argument.
1.641 + */
1.642 +
1.643 + if (arg >= objc) {
1.644 + goto badIndex;
1.645 + }
1.646 + if (count == BINARY_ALL) {
1.647 + Tcl_GetByteArrayFromObj(objv[arg], &count);
1.648 + } else if (count == BINARY_NOCOUNT) {
1.649 + count = 1;
1.650 + }
1.651 + arg++;
1.652 + if (cmd == 'a' || cmd == 'A') {
1.653 + offset += count;
1.654 + } else if (cmd == 'b' || cmd == 'B') {
1.655 + offset += (count + 7) / 8;
1.656 + } else {
1.657 + offset += (count + 1) / 2;
1.658 + }
1.659 + break;
1.660 + }
1.661 + case 'c': {
1.662 + size = 1;
1.663 + goto doNumbers;
1.664 + }
1.665 + case 's':
1.666 + case 'S': {
1.667 + size = 2;
1.668 + goto doNumbers;
1.669 + }
1.670 + case 'i':
1.671 + case 'I': {
1.672 + size = 4;
1.673 + goto doNumbers;
1.674 + }
1.675 + case 'w':
1.676 + case 'W': {
1.677 + size = 8;
1.678 + goto doNumbers;
1.679 + }
1.680 + case 'f': {
1.681 + size = sizeof(float);
1.682 + goto doNumbers;
1.683 + }
1.684 + case 'd': {
1.685 + size = sizeof(double);
1.686 +
1.687 + doNumbers:
1.688 + if (arg >= objc) {
1.689 + goto badIndex;
1.690 + }
1.691 +
1.692 + /*
1.693 + * For number-type specifiers, the count corresponds
1.694 + * to the number of elements in the list stored in
1.695 + * a single argument. If no count is specified, then
1.696 + * the argument is taken as a single non-list value.
1.697 + */
1.698 +
1.699 + if (count == BINARY_NOCOUNT) {
1.700 + arg++;
1.701 + count = 1;
1.702 + } else {
1.703 + int listc;
1.704 + Tcl_Obj **listv;
1.705 + if (Tcl_ListObjGetElements(interp, objv[arg++],
1.706 + &listc, &listv) != TCL_OK) {
1.707 + return TCL_ERROR;
1.708 + }
1.709 + if (count == BINARY_ALL) {
1.710 + count = listc;
1.711 + } else if (count > listc) {
1.712 + Tcl_AppendResult(interp,
1.713 + "number of elements in list does not match count",
1.714 + (char *) NULL);
1.715 + return TCL_ERROR;
1.716 + }
1.717 + }
1.718 + offset += count*size;
1.719 + break;
1.720 + }
1.721 + case 'x': {
1.722 + if (count == BINARY_ALL) {
1.723 + Tcl_AppendResult(interp,
1.724 + "cannot use \"*\" in format string with \"x\"",
1.725 + (char *) NULL);
1.726 + return TCL_ERROR;
1.727 + } else if (count == BINARY_NOCOUNT) {
1.728 + count = 1;
1.729 + }
1.730 + offset += count;
1.731 + break;
1.732 + }
1.733 + case 'X': {
1.734 + if (count == BINARY_NOCOUNT) {
1.735 + count = 1;
1.736 + }
1.737 + if ((count > offset) || (count == BINARY_ALL)) {
1.738 + count = offset;
1.739 + }
1.740 + if (offset > length) {
1.741 + length = offset;
1.742 + }
1.743 + offset -= count;
1.744 + break;
1.745 + }
1.746 + case '@': {
1.747 + if (offset > length) {
1.748 + length = offset;
1.749 + }
1.750 + if (count == BINARY_ALL) {
1.751 + offset = length;
1.752 + } else if (count == BINARY_NOCOUNT) {
1.753 + goto badCount;
1.754 + } else {
1.755 + offset = count;
1.756 + }
1.757 + break;
1.758 + }
1.759 + default: {
1.760 + errorString = str;
1.761 + goto badField;
1.762 + }
1.763 + }
1.764 + }
1.765 + if (offset > length) {
1.766 + length = offset;
1.767 + }
1.768 + if (length == 0) {
1.769 + return TCL_OK;
1.770 + }
1.771 +
1.772 + /*
1.773 + * Prepare the result object by preallocating the caclulated
1.774 + * number of bytes and filling with nulls.
1.775 + */
1.776 +
1.777 + resultPtr = Tcl_GetObjResult(interp);
1.778 + buffer = Tcl_SetByteArrayLength(resultPtr, length);
1.779 + memset((VOID *) buffer, 0, (size_t) length);
1.780 +
1.781 + /*
1.782 + * Pack the data into the result object. Note that we can skip
1.783 + * the error checking during this pass, since we have already
1.784 + * parsed the string once.
1.785 + */
1.786 +
1.787 + arg = 3;
1.788 + format = Tcl_GetString(objv[2]);
1.789 + cursor = buffer;
1.790 + maxPos = cursor;
1.791 + while (*format != 0) {
1.792 + if (!GetFormatSpec(&format, &cmd, &count)) {
1.793 + break;
1.794 + }
1.795 + if ((count == 0) && (cmd != '@')) {
1.796 + arg++;
1.797 + continue;
1.798 + }
1.799 + switch (cmd) {
1.800 + case 'a':
1.801 + case 'A': {
1.802 + char pad = (char) (cmd == 'a' ? '\0' : ' ');
1.803 + unsigned char *bytes;
1.804 +
1.805 + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length);
1.806 +
1.807 + if (count == BINARY_ALL) {
1.808 + count = length;
1.809 + } else if (count == BINARY_NOCOUNT) {
1.810 + count = 1;
1.811 + }
1.812 + if (length >= count) {
1.813 + memcpy((VOID *) cursor, (VOID *) bytes,
1.814 + (size_t) count);
1.815 + } else {
1.816 + memcpy((VOID *) cursor, (VOID *) bytes,
1.817 + (size_t) length);
1.818 + memset((VOID *) (cursor + length), pad,
1.819 + (size_t) (count - length));
1.820 + }
1.821 + cursor += count;
1.822 + break;
1.823 + }
1.824 + case 'b':
1.825 + case 'B': {
1.826 + unsigned char *last;
1.827 +
1.828 + str = Tcl_GetStringFromObj(objv[arg++], &length);
1.829 + if (count == BINARY_ALL) {
1.830 + count = length;
1.831 + } else if (count == BINARY_NOCOUNT) {
1.832 + count = 1;
1.833 + }
1.834 + last = cursor + ((count + 7) / 8);
1.835 + if (count > length) {
1.836 + count = length;
1.837 + }
1.838 + value = 0;
1.839 + errorString = "binary";
1.840 + if (cmd == 'B') {
1.841 + for (offset = 0; offset < count; offset++) {
1.842 + value <<= 1;
1.843 + if (str[offset] == '1') {
1.844 + value |= 1;
1.845 + } else if (str[offset] != '0') {
1.846 + errorValue = str;
1.847 + goto badValue;
1.848 + }
1.849 + if (((offset + 1) % 8) == 0) {
1.850 + *cursor++ = (unsigned char) value;
1.851 + value = 0;
1.852 + }
1.853 + }
1.854 + } else {
1.855 + for (offset = 0; offset < count; offset++) {
1.856 + value >>= 1;
1.857 + if (str[offset] == '1') {
1.858 + value |= 128;
1.859 + } else if (str[offset] != '0') {
1.860 + errorValue = str;
1.861 + goto badValue;
1.862 + }
1.863 + if (!((offset + 1) % 8)) {
1.864 + *cursor++ = (unsigned char) value;
1.865 + value = 0;
1.866 + }
1.867 + }
1.868 + }
1.869 + if ((offset % 8) != 0) {
1.870 + if (cmd == 'B') {
1.871 + value <<= 8 - (offset % 8);
1.872 + } else {
1.873 + value >>= 8 - (offset % 8);
1.874 + }
1.875 + *cursor++ = (unsigned char) value;
1.876 + }
1.877 + while (cursor < last) {
1.878 + *cursor++ = '\0';
1.879 + }
1.880 + break;
1.881 + }
1.882 + case 'h':
1.883 + case 'H': {
1.884 + unsigned char *last;
1.885 + int c;
1.886 +
1.887 + str = Tcl_GetStringFromObj(objv[arg++], &length);
1.888 + if (count == BINARY_ALL) {
1.889 + count = length;
1.890 + } else if (count == BINARY_NOCOUNT) {
1.891 + count = 1;
1.892 + }
1.893 + last = cursor + ((count + 1) / 2);
1.894 + if (count > length) {
1.895 + count = length;
1.896 + }
1.897 + value = 0;
1.898 + errorString = "hexadecimal";
1.899 + if (cmd == 'H') {
1.900 + for (offset = 0; offset < count; offset++) {
1.901 + value <<= 4;
1.902 + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
1.903 + errorValue = str;
1.904 + goto badValue;
1.905 + }
1.906 + c = str[offset] - '0';
1.907 + if (c > 9) {
1.908 + c += ('0' - 'A') + 10;
1.909 + }
1.910 + if (c > 16) {
1.911 + c += ('A' - 'a');
1.912 + }
1.913 + value |= (c & 0xf);
1.914 + if (offset % 2) {
1.915 + *cursor++ = (char) value;
1.916 + value = 0;
1.917 + }
1.918 + }
1.919 + } else {
1.920 + for (offset = 0; offset < count; offset++) {
1.921 + value >>= 4;
1.922 +
1.923 + if (!isxdigit(UCHAR(str[offset]))) { /* INTL: digit */
1.924 + errorValue = str;
1.925 + goto badValue;
1.926 + }
1.927 + c = str[offset] - '0';
1.928 + if (c > 9) {
1.929 + c += ('0' - 'A') + 10;
1.930 + }
1.931 + if (c > 16) {
1.932 + c += ('A' - 'a');
1.933 + }
1.934 + value |= ((c << 4) & 0xf0);
1.935 + if (offset % 2) {
1.936 + *cursor++ = (unsigned char)(value & 0xff);
1.937 + value = 0;
1.938 + }
1.939 + }
1.940 + }
1.941 + if (offset % 2) {
1.942 + if (cmd == 'H') {
1.943 + value <<= 4;
1.944 + } else {
1.945 + value >>= 4;
1.946 + }
1.947 + *cursor++ = (unsigned char) value;
1.948 + }
1.949 +
1.950 + while (cursor < last) {
1.951 + *cursor++ = '\0';
1.952 + }
1.953 + break;
1.954 + }
1.955 + case 'c':
1.956 + case 's':
1.957 + case 'S':
1.958 + case 'i':
1.959 + case 'I':
1.960 + case 'w':
1.961 + case 'W':
1.962 + case 'd':
1.963 + case 'f': {
1.964 + int listc, i;
1.965 + Tcl_Obj **listv;
1.966 +
1.967 + if (count == BINARY_NOCOUNT) {
1.968 + /*
1.969 + * Note that we are casting away the const-ness of
1.970 + * objv, but this is safe since we aren't going to
1.971 + * modify the array.
1.972 + */
1.973 +
1.974 + listv = (Tcl_Obj**)(objv + arg);
1.975 + listc = 1;
1.976 + count = 1;
1.977 + } else {
1.978 + Tcl_ListObjGetElements(interp, objv[arg],
1.979 + &listc, &listv);
1.980 + if (count == BINARY_ALL) {
1.981 + count = listc;
1.982 + }
1.983 + }
1.984 + arg++;
1.985 + for (i = 0; i < count; i++) {
1.986 + if (FormatNumber(interp, cmd, listv[i], &cursor)
1.987 + != TCL_OK) {
1.988 + return TCL_ERROR;
1.989 + }
1.990 + }
1.991 + break;
1.992 + }
1.993 + case 'x': {
1.994 + if (count == BINARY_NOCOUNT) {
1.995 + count = 1;
1.996 + }
1.997 + memset(cursor, 0, (size_t) count);
1.998 + cursor += count;
1.999 + break;
1.1000 + }
1.1001 + case 'X': {
1.1002 + if (cursor > maxPos) {
1.1003 + maxPos = cursor;
1.1004 + }
1.1005 + if (count == BINARY_NOCOUNT) {
1.1006 + count = 1;
1.1007 + }
1.1008 + if ((count == BINARY_ALL)
1.1009 + || (count > (cursor - buffer))) {
1.1010 + cursor = buffer;
1.1011 + } else {
1.1012 + cursor -= count;
1.1013 + }
1.1014 + break;
1.1015 + }
1.1016 + case '@': {
1.1017 + if (cursor > maxPos) {
1.1018 + maxPos = cursor;
1.1019 + }
1.1020 + if (count == BINARY_ALL) {
1.1021 + cursor = maxPos;
1.1022 + } else {
1.1023 + cursor = buffer + count;
1.1024 + }
1.1025 + break;
1.1026 + }
1.1027 + }
1.1028 + }
1.1029 + break;
1.1030 + }
1.1031 + case BINARY_SCAN: {
1.1032 + int i;
1.1033 + Tcl_Obj *valuePtr, *elementPtr;
1.1034 + Tcl_HashTable numberCacheHash;
1.1035 + Tcl_HashTable *numberCachePtr;
1.1036 +
1.1037 + if (objc < 4) {
1.1038 + Tcl_WrongNumArgs(interp, 2, objv,
1.1039 + "value formatString ?varName varName ...?");
1.1040 + return TCL_ERROR;
1.1041 + }
1.1042 + numberCachePtr = &numberCacheHash;
1.1043 + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS);
1.1044 + buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
1.1045 + format = Tcl_GetString(objv[3]);
1.1046 + cursor = buffer;
1.1047 + arg = 4;
1.1048 + offset = 0;
1.1049 + while (*format != '\0') {
1.1050 + str = format;
1.1051 + if (!GetFormatSpec(&format, &cmd, &count)) {
1.1052 + goto done;
1.1053 + }
1.1054 + switch (cmd) {
1.1055 + case 'a':
1.1056 + case 'A': {
1.1057 + unsigned char *src;
1.1058 +
1.1059 + if (arg >= objc) {
1.1060 + DeleteScanNumberCache(numberCachePtr);
1.1061 + goto badIndex;
1.1062 + }
1.1063 + if (count == BINARY_ALL) {
1.1064 + count = length - offset;
1.1065 + } else {
1.1066 + if (count == BINARY_NOCOUNT) {
1.1067 + count = 1;
1.1068 + }
1.1069 + if (count > (length - offset)) {
1.1070 + goto done;
1.1071 + }
1.1072 + }
1.1073 +
1.1074 + src = buffer + offset;
1.1075 + size = count;
1.1076 +
1.1077 + /*
1.1078 + * Trim trailing nulls and spaces, if necessary.
1.1079 + */
1.1080 +
1.1081 + if (cmd == 'A') {
1.1082 + while (size > 0) {
1.1083 + if (src[size-1] != '\0' && src[size-1] != ' ') {
1.1084 + break;
1.1085 + }
1.1086 + size--;
1.1087 + }
1.1088 + }
1.1089 + valuePtr = Tcl_NewByteArrayObj(src, size);
1.1090 + Tcl_IncrRefCount(valuePtr);
1.1091 + resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
1.1092 + NULL, valuePtr, TCL_LEAVE_ERR_MSG);
1.1093 + Tcl_DecrRefCount(valuePtr);
1.1094 + arg++;
1.1095 + if (resultPtr == NULL) {
1.1096 + DeleteScanNumberCache(numberCachePtr);
1.1097 + return TCL_ERROR;
1.1098 + }
1.1099 + offset += count;
1.1100 + break;
1.1101 + }
1.1102 + case 'b':
1.1103 + case 'B': {
1.1104 + unsigned char *src;
1.1105 + char *dest;
1.1106 +
1.1107 + if (arg >= objc) {
1.1108 + DeleteScanNumberCache(numberCachePtr);
1.1109 + goto badIndex;
1.1110 + }
1.1111 + if (count == BINARY_ALL) {
1.1112 + count = (length - offset) * 8;
1.1113 + } else {
1.1114 + if (count == BINARY_NOCOUNT) {
1.1115 + count = 1;
1.1116 + }
1.1117 + if (count > (length - offset) * 8) {
1.1118 + goto done;
1.1119 + }
1.1120 + }
1.1121 + src = buffer + offset;
1.1122 + valuePtr = Tcl_NewObj();
1.1123 + Tcl_SetObjLength(valuePtr, count);
1.1124 + dest = Tcl_GetString(valuePtr);
1.1125 +
1.1126 + if (cmd == 'b') {
1.1127 + for (i = 0; i < count; i++) {
1.1128 + if (i % 8) {
1.1129 + value >>= 1;
1.1130 + } else {
1.1131 + value = *src++;
1.1132 + }
1.1133 + *dest++ = (char) ((value & 1) ? '1' : '0');
1.1134 + }
1.1135 + } else {
1.1136 + for (i = 0; i < count; i++) {
1.1137 + if (i % 8) {
1.1138 + value <<= 1;
1.1139 + } else {
1.1140 + value = *src++;
1.1141 + }
1.1142 + *dest++ = (char) ((value & 0x80) ? '1' : '0');
1.1143 + }
1.1144 + }
1.1145 +
1.1146 + Tcl_IncrRefCount(valuePtr);
1.1147 + resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
1.1148 + NULL, valuePtr, TCL_LEAVE_ERR_MSG);
1.1149 + Tcl_DecrRefCount(valuePtr);
1.1150 + arg++;
1.1151 + if (resultPtr == NULL) {
1.1152 + DeleteScanNumberCache(numberCachePtr);
1.1153 + return TCL_ERROR;
1.1154 + }
1.1155 + offset += (count + 7 ) / 8;
1.1156 + break;
1.1157 + }
1.1158 + case 'h':
1.1159 + case 'H': {
1.1160 + char *dest;
1.1161 + unsigned char *src;
1.1162 + int i;
1.1163 + static char hexdigit[] = "0123456789abcdef";
1.1164 +
1.1165 + if (arg >= objc) {
1.1166 + DeleteScanNumberCache(numberCachePtr);
1.1167 + goto badIndex;
1.1168 + }
1.1169 + if (count == BINARY_ALL) {
1.1170 + count = (length - offset)*2;
1.1171 + } else {
1.1172 + if (count == BINARY_NOCOUNT) {
1.1173 + count = 1;
1.1174 + }
1.1175 + if (count > (length - offset)*2) {
1.1176 + goto done;
1.1177 + }
1.1178 + }
1.1179 + src = buffer + offset;
1.1180 + valuePtr = Tcl_NewObj();
1.1181 + Tcl_SetObjLength(valuePtr, count);
1.1182 + dest = Tcl_GetString(valuePtr);
1.1183 +
1.1184 + if (cmd == 'h') {
1.1185 + for (i = 0; i < count; i++) {
1.1186 + if (i % 2) {
1.1187 + value >>= 4;
1.1188 + } else {
1.1189 + value = *src++;
1.1190 + }
1.1191 + *dest++ = hexdigit[value & 0xf];
1.1192 + }
1.1193 + } else {
1.1194 + for (i = 0; i < count; i++) {
1.1195 + if (i % 2) {
1.1196 + value <<= 4;
1.1197 + } else {
1.1198 + value = *src++;
1.1199 + }
1.1200 + *dest++ = hexdigit[(value >> 4) & 0xf];
1.1201 + }
1.1202 + }
1.1203 +
1.1204 + Tcl_IncrRefCount(valuePtr);
1.1205 + resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
1.1206 + NULL, valuePtr, TCL_LEAVE_ERR_MSG);
1.1207 + Tcl_DecrRefCount(valuePtr);
1.1208 + arg++;
1.1209 + if (resultPtr == NULL) {
1.1210 + DeleteScanNumberCache(numberCachePtr);
1.1211 + return TCL_ERROR;
1.1212 + }
1.1213 + offset += (count + 1) / 2;
1.1214 + break;
1.1215 + }
1.1216 + case 'c': {
1.1217 + size = 1;
1.1218 + goto scanNumber;
1.1219 + }
1.1220 + case 's':
1.1221 + case 'S': {
1.1222 + size = 2;
1.1223 + goto scanNumber;
1.1224 + }
1.1225 + case 'i':
1.1226 + case 'I': {
1.1227 + size = 4;
1.1228 + goto scanNumber;
1.1229 + }
1.1230 + case 'w':
1.1231 + case 'W': {
1.1232 + size = 8;
1.1233 + goto scanNumber;
1.1234 + }
1.1235 + case 'f': {
1.1236 + size = sizeof(float);
1.1237 + goto scanNumber;
1.1238 + }
1.1239 + case 'd': {
1.1240 + unsigned char *src;
1.1241 +
1.1242 + size = sizeof(double);
1.1243 + /* fall through */
1.1244 +
1.1245 + scanNumber:
1.1246 + if (arg >= objc) {
1.1247 + DeleteScanNumberCache(numberCachePtr);
1.1248 + goto badIndex;
1.1249 + }
1.1250 + if (count == BINARY_NOCOUNT) {
1.1251 + if ((length - offset) < size) {
1.1252 + goto done;
1.1253 + }
1.1254 + valuePtr = ScanNumber(buffer+offset, cmd,
1.1255 + &numberCachePtr);
1.1256 + offset += size;
1.1257 + } else {
1.1258 + if (count == BINARY_ALL) {
1.1259 + count = (length - offset) / size;
1.1260 + }
1.1261 + if ((length - offset) < (count * size)) {
1.1262 + goto done;
1.1263 + }
1.1264 + valuePtr = Tcl_NewObj();
1.1265 + src = buffer+offset;
1.1266 + for (i = 0; i < count; i++) {
1.1267 + elementPtr = ScanNumber(src, cmd,
1.1268 + &numberCachePtr);
1.1269 + src += size;
1.1270 + Tcl_ListObjAppendElement(NULL, valuePtr,
1.1271 + elementPtr);
1.1272 + }
1.1273 + offset += count*size;
1.1274 + }
1.1275 +
1.1276 + Tcl_IncrRefCount(valuePtr);
1.1277 + resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
1.1278 + NULL, valuePtr, TCL_LEAVE_ERR_MSG);
1.1279 + Tcl_DecrRefCount(valuePtr);
1.1280 + arg++;
1.1281 + if (resultPtr == NULL) {
1.1282 + DeleteScanNumberCache(numberCachePtr);
1.1283 + return TCL_ERROR;
1.1284 + }
1.1285 + break;
1.1286 + }
1.1287 + case 'x': {
1.1288 + if (count == BINARY_NOCOUNT) {
1.1289 + count = 1;
1.1290 + }
1.1291 + if ((count == BINARY_ALL)
1.1292 + || (count > (length - offset))) {
1.1293 + offset = length;
1.1294 + } else {
1.1295 + offset += count;
1.1296 + }
1.1297 + break;
1.1298 + }
1.1299 + case 'X': {
1.1300 + if (count == BINARY_NOCOUNT) {
1.1301 + count = 1;
1.1302 + }
1.1303 + if ((count == BINARY_ALL) || (count > offset)) {
1.1304 + offset = 0;
1.1305 + } else {
1.1306 + offset -= count;
1.1307 + }
1.1308 + break;
1.1309 + }
1.1310 + case '@': {
1.1311 + if (count == BINARY_NOCOUNT) {
1.1312 + DeleteScanNumberCache(numberCachePtr);
1.1313 + goto badCount;
1.1314 + }
1.1315 + if ((count == BINARY_ALL) || (count > length)) {
1.1316 + offset = length;
1.1317 + } else {
1.1318 + offset = count;
1.1319 + }
1.1320 + break;
1.1321 + }
1.1322 + default: {
1.1323 + DeleteScanNumberCache(numberCachePtr);
1.1324 + errorString = str;
1.1325 + goto badField;
1.1326 + }
1.1327 + }
1.1328 + }
1.1329 +
1.1330 + /*
1.1331 + * Set the result to the last position of the cursor.
1.1332 + */
1.1333 +
1.1334 + done:
1.1335 + Tcl_ResetResult(interp);
1.1336 + Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
1.1337 + DeleteScanNumberCache(numberCachePtr);
1.1338 + break;
1.1339 + }
1.1340 + }
1.1341 + return TCL_OK;
1.1342 +
1.1343 + badValue:
1.1344 + Tcl_ResetResult(interp);
1.1345 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
1.1346 + " string but got \"", errorValue, "\" instead", NULL);
1.1347 + return TCL_ERROR;
1.1348 +
1.1349 + badCount:
1.1350 + errorString = "missing count for \"@\" field specifier";
1.1351 + goto error;
1.1352 +
1.1353 + badIndex:
1.1354 + errorString = "not enough arguments for all format specifiers";
1.1355 + goto error;
1.1356 +
1.1357 + badField:
1.1358 + {
1.1359 + Tcl_UniChar ch;
1.1360 + char buf[TCL_UTF_MAX + 1];
1.1361 +
1.1362 + Tcl_UtfToUniChar(errorString, &ch);
1.1363 + buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
1.1364 + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL);
1.1365 + return TCL_ERROR;
1.1366 + }
1.1367 +
1.1368 + error:
1.1369 + Tcl_AppendResult(interp, errorString, NULL);
1.1370 + return TCL_ERROR;
1.1371 +}
1.1372 +
1.1373 +/*
1.1374 + *----------------------------------------------------------------------
1.1375 + *
1.1376 + * GetFormatSpec --
1.1377 + *
1.1378 + * This function parses the format strings used in the binary
1.1379 + * format and scan commands.
1.1380 + *
1.1381 + * Results:
1.1382 + * Moves the formatPtr to the start of the next command. Returns
1.1383 + * the current command character and count in cmdPtr and countPtr.
1.1384 + * The count is set to BINARY_ALL if the count character was '*'
1.1385 + * or BINARY_NOCOUNT if no count was specified. Returns 1 on
1.1386 + * success, or 0 if the string did not have a format specifier.
1.1387 + *
1.1388 + * Side effects:
1.1389 + * None.
1.1390 + *
1.1391 + *----------------------------------------------------------------------
1.1392 + */
1.1393 +
1.1394 +static int
1.1395 +GetFormatSpec(formatPtr, cmdPtr, countPtr)
1.1396 + char **formatPtr; /* Pointer to format string. */
1.1397 + char *cmdPtr; /* Pointer to location of command char. */
1.1398 + int *countPtr; /* Pointer to repeat count value. */
1.1399 +{
1.1400 + /*
1.1401 + * Skip any leading blanks.
1.1402 + */
1.1403 +
1.1404 + while (**formatPtr == ' ') {
1.1405 + (*formatPtr)++;
1.1406 + }
1.1407 +
1.1408 + /*
1.1409 + * The string was empty, except for whitespace, so fail.
1.1410 + */
1.1411 +
1.1412 + if (!(**formatPtr)) {
1.1413 + return 0;
1.1414 + }
1.1415 +
1.1416 + /*
1.1417 + * Extract the command character and any trailing digits or '*'.
1.1418 + */
1.1419 +
1.1420 + *cmdPtr = **formatPtr;
1.1421 + (*formatPtr)++;
1.1422 + if (**formatPtr == '*') {
1.1423 + (*formatPtr)++;
1.1424 + (*countPtr) = BINARY_ALL;
1.1425 + } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
1.1426 + (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
1.1427 + } else {
1.1428 + (*countPtr) = BINARY_NOCOUNT;
1.1429 + }
1.1430 + return 1;
1.1431 +}
1.1432 +
1.1433 +/*
1.1434 + *----------------------------------------------------------------------
1.1435 + *
1.1436 + * FormatNumber --
1.1437 + *
1.1438 + * This routine is called by Tcl_BinaryObjCmd to format a number
1.1439 + * into a location pointed at by cursor.
1.1440 + *
1.1441 + * Results:
1.1442 + * A standard Tcl result.
1.1443 + *
1.1444 + * Side effects:
1.1445 + * Moves the cursor to the next location to be written into.
1.1446 + *
1.1447 + *----------------------------------------------------------------------
1.1448 + */
1.1449 +
1.1450 +static int
1.1451 +FormatNumber(interp, type, src, cursorPtr)
1.1452 + Tcl_Interp *interp; /* Current interpreter, used to report
1.1453 + * errors. */
1.1454 + int type; /* Type of number to format. */
1.1455 + Tcl_Obj *src; /* Number to format. */
1.1456 + unsigned char **cursorPtr; /* Pointer to index into destination buffer. */
1.1457 +{
1.1458 + long value;
1.1459 + double dvalue;
1.1460 + Tcl_WideInt wvalue;
1.1461 +
1.1462 + switch (type) {
1.1463 + case 'd':
1.1464 + case 'f':
1.1465 + /*
1.1466 + * For floating point types, we need to copy the data using
1.1467 + * memcpy to avoid alignment issues.
1.1468 + */
1.1469 +
1.1470 + if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
1.1471 + return TCL_ERROR;
1.1472 + }
1.1473 + if (type == 'd') {
1.1474 + /*
1.1475 + * Can't just memcpy() here. [Bug 1116542]
1.1476 + */
1.1477 +
1.1478 + CopyNumber(&dvalue, *cursorPtr, sizeof(double));
1.1479 + *cursorPtr += sizeof(double);
1.1480 + } else {
1.1481 + float fvalue;
1.1482 +
1.1483 + /*
1.1484 + * Because some compilers will generate floating point exceptions
1.1485 + * on an overflow cast (e.g. Borland), we restrict the values
1.1486 + * to the valid range for float.
1.1487 + */
1.1488 +
1.1489 + if (fabs(dvalue) > (double)FLT_MAX) {
1.1490 + fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
1.1491 + } else {
1.1492 + fvalue = (float) dvalue;
1.1493 + }
1.1494 + memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
1.1495 + *cursorPtr += sizeof(float);
1.1496 + }
1.1497 + return TCL_OK;
1.1498 +
1.1499 + /*
1.1500 + * Next cases separate from other integer cases because we
1.1501 + * need a different API to get a wide.
1.1502 + */
1.1503 + case 'w':
1.1504 + case 'W':
1.1505 + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
1.1506 + return TCL_ERROR;
1.1507 + }
1.1508 + if (type == 'w') {
1.1509 + *(*cursorPtr)++ = (unsigned char) wvalue;
1.1510 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
1.1511 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
1.1512 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
1.1513 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
1.1514 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
1.1515 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
1.1516 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
1.1517 + } else {
1.1518 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
1.1519 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
1.1520 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
1.1521 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
1.1522 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
1.1523 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
1.1524 + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
1.1525 + *(*cursorPtr)++ = (unsigned char) wvalue;
1.1526 + }
1.1527 + return TCL_OK;
1.1528 + default:
1.1529 + if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
1.1530 + return TCL_ERROR;
1.1531 + }
1.1532 + if (type == 'c') {
1.1533 + *(*cursorPtr)++ = (unsigned char) value;
1.1534 + } else if (type == 's') {
1.1535 + *(*cursorPtr)++ = (unsigned char) value;
1.1536 + *(*cursorPtr)++ = (unsigned char) (value >> 8);
1.1537 + } else if (type == 'S') {
1.1538 + *(*cursorPtr)++ = (unsigned char) (value >> 8);
1.1539 + *(*cursorPtr)++ = (unsigned char) value;
1.1540 + } else if (type == 'i') {
1.1541 + *(*cursorPtr)++ = (unsigned char) value;
1.1542 + *(*cursorPtr)++ = (unsigned char) (value >> 8);
1.1543 + *(*cursorPtr)++ = (unsigned char) (value >> 16);
1.1544 + *(*cursorPtr)++ = (unsigned char) (value >> 24);
1.1545 + } else if (type == 'I') {
1.1546 + *(*cursorPtr)++ = (unsigned char) (value >> 24);
1.1547 + *(*cursorPtr)++ = (unsigned char) (value >> 16);
1.1548 + *(*cursorPtr)++ = (unsigned char) (value >> 8);
1.1549 + *(*cursorPtr)++ = (unsigned char) value;
1.1550 + }
1.1551 + return TCL_OK;
1.1552 + }
1.1553 +}
1.1554 +
1.1555 +/* Ugly workaround for old and broken compiler! */
1.1556 +static void
1.1557 +CopyNumber(from, to, length)
1.1558 + CONST VOID *from;
1.1559 + VOID *to;
1.1560 + unsigned int length;
1.1561 +{
1.1562 + memcpy(to, from, length);
1.1563 +}
1.1564 +
1.1565 +/*
1.1566 + *----------------------------------------------------------------------
1.1567 + *
1.1568 + * ScanNumber --
1.1569 + *
1.1570 + * This routine is called by Tcl_BinaryObjCmd to scan a number
1.1571 + * out of a buffer.
1.1572 + *
1.1573 + * Results:
1.1574 + * Returns a newly created object containing the scanned number.
1.1575 + * This object has a ref count of zero.
1.1576 + *
1.1577 + * Side effects:
1.1578 + * Might reuse an object in the number cache, place a new object
1.1579 + * in the cache, or delete the cache and set the reference to
1.1580 + * it (itself passed in by reference) to NULL.
1.1581 + *
1.1582 + *----------------------------------------------------------------------
1.1583 + */
1.1584 +
1.1585 +static Tcl_Obj *
1.1586 +ScanNumber(buffer, type, numberCachePtrPtr)
1.1587 + unsigned char *buffer; /* Buffer to scan number from. */
1.1588 + int type; /* Format character from "binary scan" */
1.1589 + Tcl_HashTable **numberCachePtrPtr;
1.1590 + /* Place to look for cache of scanned
1.1591 + * value objects, or NULL if too many
1.1592 + * different numbers have been scanned. */
1.1593 +{
1.1594 + long value;
1.1595 + Tcl_WideUInt uwvalue;
1.1596 +
1.1597 + /*
1.1598 + * We cannot rely on the compiler to properly sign extend integer values
1.1599 + * when we cast from smaller values to larger values because we don't know
1.1600 + * the exact size of the integer types. So, we have to handle sign
1.1601 + * extension explicitly by checking the high bit and padding with 1's as
1.1602 + * needed.
1.1603 + */
1.1604 +
1.1605 + switch (type) {
1.1606 + case 'c':
1.1607 + /*
1.1608 + * Characters need special handling. We want to produce a
1.1609 + * signed result, but on some platforms (such as AIX) chars
1.1610 + * are unsigned. To deal with this, check for a value that
1.1611 + * should be negative but isn't.
1.1612 + */
1.1613 +
1.1614 + value = buffer[0];
1.1615 + if (value & 0x80) {
1.1616 + value |= -0x100;
1.1617 + }
1.1618 + goto returnNumericObject;
1.1619 +
1.1620 + case 's':
1.1621 + value = (long) (buffer[0] + (buffer[1] << 8));
1.1622 + goto shortValue;
1.1623 + case 'S':
1.1624 + value = (long) (buffer[1] + (buffer[0] << 8));
1.1625 + shortValue:
1.1626 + if (value & 0x8000) {
1.1627 + value |= -0x10000;
1.1628 + }
1.1629 + goto returnNumericObject;
1.1630 +
1.1631 + case 'i':
1.1632 + value = (long) (buffer[0]
1.1633 + + (buffer[1] << 8)
1.1634 + + (buffer[2] << 16)
1.1635 + + (buffer[3] << 24));
1.1636 + goto intValue;
1.1637 + case 'I':
1.1638 + value = (long) (buffer[3]
1.1639 + + (buffer[2] << 8)
1.1640 + + (buffer[1] << 16)
1.1641 + + (buffer[0] << 24));
1.1642 + intValue:
1.1643 + /*
1.1644 + * Check to see if the value was sign extended properly on
1.1645 + * systems where an int is more than 32-bits.
1.1646 + */
1.1647 +
1.1648 + if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
1.1649 + value -= (((unsigned int)1)<<31);
1.1650 + value -= (((unsigned int)1)<<31);
1.1651 + }
1.1652 + returnNumericObject:
1.1653 + if (*numberCachePtrPtr == NULL) {
1.1654 + return Tcl_NewLongObj(value);
1.1655 + } else {
1.1656 + register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
1.1657 + register Tcl_HashEntry *hPtr;
1.1658 + int isNew;
1.1659 +
1.1660 + hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
1.1661 + if (!isNew) {
1.1662 + return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
1.1663 + }
1.1664 + if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
1.1665 + /*
1.1666 + * We've overflowed the cache! Someone's parsing
1.1667 + * a LOT of varied binary data in a single call!
1.1668 + * Bail out by switching back to the old behaviour
1.1669 + * for the rest of the scan.
1.1670 + *
1.1671 + * Note that anyone just using the 'c' conversion
1.1672 + * (for bytes) cannot trigger this.
1.1673 + */
1.1674 + DeleteScanNumberCache(tablePtr);
1.1675 + *numberCachePtrPtr = NULL;
1.1676 + return Tcl_NewLongObj(value);
1.1677 + } else {
1.1678 + register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
1.1679 +
1.1680 + Tcl_IncrRefCount(objPtr);
1.1681 + Tcl_SetHashValue(hPtr, (ClientData) objPtr);
1.1682 + return objPtr;
1.1683 + }
1.1684 + }
1.1685 +
1.1686 + /*
1.1687 + * Do not cache wide values; they are already too large to
1.1688 + * use as keys.
1.1689 + */
1.1690 + case 'w':
1.1691 + uwvalue = ((Tcl_WideUInt) buffer[0])
1.1692 + | (((Tcl_WideUInt) buffer[1]) << 8)
1.1693 + | (((Tcl_WideUInt) buffer[2]) << 16)
1.1694 + | (((Tcl_WideUInt) buffer[3]) << 24)
1.1695 + | (((Tcl_WideUInt) buffer[4]) << 32)
1.1696 + | (((Tcl_WideUInt) buffer[5]) << 40)
1.1697 + | (((Tcl_WideUInt) buffer[6]) << 48)
1.1698 + | (((Tcl_WideUInt) buffer[7]) << 56);
1.1699 + return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
1.1700 + case 'W':
1.1701 + uwvalue = ((Tcl_WideUInt) buffer[7])
1.1702 + | (((Tcl_WideUInt) buffer[6]) << 8)
1.1703 + | (((Tcl_WideUInt) buffer[5]) << 16)
1.1704 + | (((Tcl_WideUInt) buffer[4]) << 24)
1.1705 + | (((Tcl_WideUInt) buffer[3]) << 32)
1.1706 + | (((Tcl_WideUInt) buffer[2]) << 40)
1.1707 + | (((Tcl_WideUInt) buffer[1]) << 48)
1.1708 + | (((Tcl_WideUInt) buffer[0]) << 56);
1.1709 + return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
1.1710 +
1.1711 + /*
1.1712 + * Do not cache double values; they are already too large
1.1713 + * to use as keys and the values stored are utterly
1.1714 + * incompatible too.
1.1715 + */
1.1716 + case 'f': {
1.1717 + float fvalue;
1.1718 + memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
1.1719 + return Tcl_NewDoubleObj(fvalue);
1.1720 + }
1.1721 + case 'd': {
1.1722 + double dvalue;
1.1723 + memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
1.1724 + return Tcl_NewDoubleObj(dvalue);
1.1725 + }
1.1726 + }
1.1727 + return NULL;
1.1728 +}
1.1729 +
1.1730 +/*
1.1731 + *----------------------------------------------------------------------
1.1732 + *
1.1733 + * DeleteScanNumberCache --
1.1734 + *
1.1735 + * Deletes the hash table acting as a scan number cache.
1.1736 + *
1.1737 + * Results:
1.1738 + * None
1.1739 + *
1.1740 + * Side effects:
1.1741 + * Decrements the reference counts of the objects in the cache.
1.1742 + *
1.1743 + *----------------------------------------------------------------------
1.1744 + */
1.1745 +
1.1746 +static void
1.1747 +DeleteScanNumberCache(numberCachePtr)
1.1748 + Tcl_HashTable *numberCachePtr; /* Pointer to the hash table, or
1.1749 + * NULL (when the cache has already
1.1750 + * been deleted due to overflow.) */
1.1751 +{
1.1752 + Tcl_HashEntry *hEntry;
1.1753 + Tcl_HashSearch search;
1.1754 +
1.1755 + if (numberCachePtr == NULL) {
1.1756 + return;
1.1757 + }
1.1758 +
1.1759 + hEntry = Tcl_FirstHashEntry(numberCachePtr, &search);
1.1760 + while (hEntry != NULL) {
1.1761 + register Tcl_Obj *value = (Tcl_Obj *) Tcl_GetHashValue(hEntry);
1.1762 +
1.1763 + if (value != NULL) {
1.1764 + Tcl_DecrRefCount(value);
1.1765 + }
1.1766 + hEntry = Tcl_NextHashEntry(&search);
1.1767 + }
1.1768 + Tcl_DeleteHashTable(numberCachePtr);
1.1769 +}