summaryrefslogtreecommitdiffstats
path: root/generic/tclBinary.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclBinary.c')
-rw-r--r--generic/tclBinary.c1013
1 files changed, 1013 insertions, 0 deletions
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
new file mode 100644
index 0000000..e15fe4c
--- /dev/null
+++ b/generic/tclBinary.c
@@ -0,0 +1,1013 @@
+/*
+ * tclBinary.c --
+ *
+ * This file contains the implementation of the "binary" Tcl built-in
+ * command .
+ *
+ * Copyright (c) 1997 by Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclBinary.c 1.26 97/11/05 13:02:05
+ */
+
+#include <math.h>
+#include "tclInt.h"
+#include "tclPort.h"
+
+/*
+ * The following constants are used by GetFormatSpec to indicate various
+ * special conditions in the parsing of a format specifier.
+ */
+
+#define BINARY_ALL -1 /* Use all elements in the argument. */
+#define BINARY_NOCOUNT -2 /* No count was specified in format. */
+
+/*
+ * Prototypes for local procedures defined in this file:
+ */
+
+static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
+ char *cmdPtr, int *countPtr));
+static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type,
+ Tcl_Obj *src, char **cursorPtr));
+static Tcl_Obj * ScanNumber _ANSI_ARGS_((char *buffer, int type));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_BinaryObjCmd --
+ *
+ * This procedure implements the "binary" Tcl command.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_BinaryObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+{
+ int arg; /* Index of next argument to consume. */
+ int value = 0; /* Current integer value to be packed.
+ * Initialized to avoid compiler warning. */
+ char cmd; /* Current format character. */
+ int count; /* Count associated with current format
+ * character. */
+ char *format; /* Pointer to current position in format
+ * string. */
+ char *cursor; /* Current position within result buffer. */
+ char *maxPos; /* Greatest position within result buffer that
+ * cursor has visited.*/
+ char *buffer; /* Start of data buffer. */
+ char *errorString, *errorValue, *str;
+ int offset, size, length;
+ Tcl_Obj *resultPtr;
+
+ static char *subCmds[] = { "format", "scan", (char *) NULL };
+ enum { BinaryFormat, BinaryScan } index;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", 0,
+ (int *) &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case BinaryFormat:
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?");
+ return TCL_ERROR;
+ }
+ /*
+ * To avoid copying the data, we format the string in two passes.
+ * The first pass computes the size of the output buffer. The
+ * second pass places the formatted data into the buffer.
+ */
+
+ format = Tcl_GetStringFromObj(objv[2], NULL);
+ arg = 3;
+ offset = length = 0;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ break;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ case 'b':
+ case 'B':
+ case 'h':
+ case 'H':
+ /*
+ * For string-type specifiers, the count corresponds
+ * to the number of characters in a single argument.
+ */
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ (void)Tcl_GetStringFromObj(objv[arg], &count);
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ arg++;
+ if (cmd == 'a' || cmd == 'A') {
+ offset += count;
+ } else if (cmd == 'b' || cmd == 'B') {
+ offset += (count + 7) / 8;
+ } else {
+ offset += (count + 1) / 2;
+ }
+ break;
+
+ case 'c':
+ size = 1;
+ goto doNumbers;
+ case 's':
+ case 'S':
+ size = 2;
+ goto doNumbers;
+ case 'i':
+ case 'I':
+ size = 4;
+ goto doNumbers;
+ case 'f':
+ size = sizeof(float);
+ goto doNumbers;
+ case 'd':
+ size = sizeof(double);
+ doNumbers:
+ if (arg >= objc) {
+ goto badIndex;
+ }
+
+ /*
+ * For number-type specifiers, the count corresponds
+ * to the number of elements in the list stored in
+ * a single argument. If no count is specified, then
+ * the argument is taken as a single non-list value.
+ */
+
+ if (count == BINARY_NOCOUNT) {
+ arg++;
+ count = 1;
+ } else {
+ int listc;
+ Tcl_Obj **listv;
+ if (Tcl_ListObjGetElements(interp, objv[arg++],
+ &listc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (count == BINARY_ALL) {
+ count = listc;
+ } else if (count > listc) {
+ errorString = "number of elements in list does not match count";
+ goto error;
+ }
+ }
+ offset += count*size;
+ break;
+
+ case 'x':
+ if (count == BINARY_ALL) {
+ errorString = "cannot use \"*\" in format string with \"x\"";
+ goto error;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ offset += count;
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count > offset) || (count == BINARY_ALL)) {
+ count = offset;
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ offset -= count;
+ break;
+ case '@':
+ if (offset > length) {
+ length = offset;
+ }
+ if (count == BINARY_ALL) {
+ offset = length;
+ } else if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ } else {
+ offset = count;
+ }
+ break;
+ default: {
+ char buf[2];
+
+ Tcl_ResetResult(interp);
+ buf[0] = cmd;
+ buf[1] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+ }
+ }
+ if (offset > length) {
+ length = offset;
+ }
+ if (length == 0) {
+ return TCL_OK;
+ }
+
+ /*
+ * Prepare the result object by preallocating the caclulated
+ * number of bytes and filling with nulls.
+ */
+
+ resultPtr = Tcl_GetObjResult(interp);
+ Tcl_SetObjLength(resultPtr, length);
+ buffer = Tcl_GetStringFromObj(resultPtr, NULL);
+ memset(buffer, 0, (size_t) length);
+
+ /*
+ * Pack the data into the result object. Note that we can skip
+ * the error checking during this pass, since we have already
+ * parsed the string once.
+ */
+
+ arg = 3;
+ format = Tcl_GetStringFromObj(objv[2], NULL);
+ cursor = buffer;
+ maxPos = cursor;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ break;
+ }
+ if ((count == 0) && (cmd != '@')) {
+ arg++;
+ continue;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A': {
+ char pad = (char) (cmd == 'a' ? '\0' : ' ');
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (length >= count) {
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) count);
+ } else {
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) length);
+ memset(cursor+length, pad,
+ (size_t) (count - length));
+ }
+ cursor += count;
+ break;
+ }
+ case 'b':
+ case 'B': {
+ char *last;
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 7) / 8);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "binary";
+ if (cmd == 'B') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 1;
+ if (str[offset] == '1') {
+ value |= 1;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ goto badValue;
+ }
+ if (((offset + 1) % 8) == 0) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 1;
+ if (str[offset] == '1') {
+ value |= 128;
+ } else if (str[offset] != '0') {
+ errorValue = str;
+ goto badValue;
+ }
+ if (!((offset + 1) % 8)) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ }
+ if ((offset % 8) != 0) {
+ if (cmd == 'B') {
+ value <<= 8 - (offset % 8);
+ } else {
+ value >>= 8 - (offset % 8);
+ }
+ *cursor++ = (char)(value & 0xff);
+ }
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *last;
+ int c;
+
+ str = Tcl_GetStringFromObj(objv[arg++], &length);
+ if (count == BINARY_ALL) {
+ count = length;
+ } else if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ last = cursor + ((count + 1) / 2);
+ if (count > length) {
+ count = length;
+ }
+ value = 0;
+ errorString = "hexadecimal";
+ if (cmd == 'H') {
+ for (offset = 0; offset < count; offset++) {
+ value <<= 4;
+ c = tolower(((unsigned char *) str)[offset]);
+ if ((c >= 'a') && (c <= 'f')) {
+ value |= ((c - 'a' + 10) & 0xf);
+ } else if ((c >= '0') && (c <= '9')) {
+ value |= (c - '0') & 0xf;
+ } else {
+ errorValue = str;
+ goto badValue;
+ }
+ if (offset % 2) {
+ *cursor++ = (char) value;
+ value = 0;
+ }
+ }
+ } else {
+ for (offset = 0; offset < count; offset++) {
+ value >>= 4;
+ c = tolower(((unsigned char *) str)[offset]);
+ if ((c >= 'a') && (c <= 'f')) {
+ value |= ((c - 'a' + 10) << 4) & 0xf0;
+ } else if ((c >= '0') && (c <= '9')) {
+ value |= ((c - '0') << 4) & 0xf0;
+ } else {
+ errorValue = str;
+ goto badValue;
+ }
+ if (offset % 2) {
+ *cursor++ = (char)(value & 0xff);
+ value = 0;
+ }
+ }
+ }
+ if (offset % 2) {
+ if (cmd == 'H') {
+ value <<= 4;
+ } else {
+ value >>= 4;
+ }
+ *cursor++ = (char) value;
+ }
+
+ while (cursor < last) {
+ *cursor++ = '\0';
+ }
+ break;
+ }
+ case 'c':
+ case 's':
+ case 'S':
+ case 'i':
+ case 'I':
+ case 'd':
+ case 'f': {
+ int listc, i;
+ Tcl_Obj **listv;
+
+ if (count == BINARY_NOCOUNT) {
+ /*
+ * Note that we are casting away the const-ness of
+ * objv, but this is safe since we aren't going to
+ * modify the array.
+ */
+
+ listv = (Tcl_Obj**)(objv + arg);
+ listc = 1;
+ count = 1;
+ } else {
+ Tcl_ListObjGetElements(interp, objv[arg],
+ &listc, &listv);
+ if (count == BINARY_ALL) {
+ count = listc;
+ }
+ }
+ arg++;
+ for (i = 0; i < count; i++) {
+ if (FormatNumber(interp, cmd, listv[i], &cursor)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ }
+ break;
+ }
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ memset(cursor, 0, (size_t) count);
+ cursor += count;
+ break;
+ case 'X':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL)
+ || (count > (cursor - buffer))) {
+ cursor = buffer;
+ } else {
+ cursor -= count;
+ }
+ break;
+ case '@':
+ if (cursor > maxPos) {
+ maxPos = cursor;
+ }
+ if (count == BINARY_ALL) {
+ cursor = maxPos;
+ } else {
+ cursor = buffer + count;
+ }
+ break;
+ }
+ }
+ break;
+
+ case BinaryScan: {
+ int i;
+ Tcl_Obj *valuePtr, *elementPtr;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "value formatString ?varName varName ...?");
+ return TCL_ERROR;
+ }
+ buffer = Tcl_GetStringFromObj(objv[2], &length);
+ format = Tcl_GetStringFromObj(objv[3], NULL);
+ cursor = buffer;
+ arg = 4;
+ offset = 0;
+ while (*format != 0) {
+ if (!GetFormatSpec(&format, &cmd, &count)) {
+ goto done;
+ }
+ switch (cmd) {
+ case 'a':
+ case 'A':
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = length - offset;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)) {
+ goto done;
+ }
+ }
+
+ str = buffer + offset;
+ size = count;
+
+ /*
+ * Trim trailing nulls and spaces, if necessary.
+ */
+
+ if (cmd == 'A') {
+ while (size > 0) {
+ if (str[size-1] != '\0' && str[size-1] != ' ') {
+ break;
+ }
+ size--;
+ }
+ }
+ valuePtr = Tcl_NewStringObj(str, size);
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += count;
+ break;
+ case 'b':
+ case 'B': {
+ char *dest;
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*8;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)*8) {
+ goto done;
+ }
+ }
+ str = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = Tcl_GetStringFromObj(valuePtr, NULL);
+
+ if (cmd == 'b') {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value >>= 1;
+ } else {
+ value = *str++;
+ }
+ *dest++ = (char) ((value & 1) ? '1' : '0');
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 8) {
+ value <<= 1;
+ } else {
+ value = *str++;
+ }
+ *dest++ = (char) ((value & 0x80) ? '1' : '0');
+ }
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += (count + 7 ) / 8;
+ break;
+ }
+ case 'h':
+ case 'H': {
+ char *dest;
+ int i;
+ static char hexdigit[] = "0123456789abcdef";
+
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_ALL) {
+ count = (length - offset)*2;
+ } else {
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if (count > (length - offset)*2) {
+ goto done;
+ }
+ }
+ str = buffer + offset;
+ valuePtr = Tcl_NewObj();
+ Tcl_SetObjLength(valuePtr, count);
+ dest = Tcl_GetStringFromObj(valuePtr, NULL);
+
+ if (cmd == 'h') {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value >>= 4;
+ } else {
+ value = *str++;
+ }
+ *dest++ = hexdigit[value & 0xf];
+ }
+ } else {
+ for (i = 0; i < count; i++) {
+ if (i % 2) {
+ value <<= 4;
+ } else {
+ value = *str++;
+ }
+ *dest++ = hexdigit[(value >> 4) & 0xf];
+ }
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ offset += (count + 1) / 2;
+ break;
+ }
+ case 'c':
+ size = 1;
+ goto scanNumber;
+ case 's':
+ case 'S':
+ size = 2;
+ goto scanNumber;
+ case 'i':
+ case 'I':
+ size = 4;
+ goto scanNumber;
+ case 'f':
+ size = sizeof(float);
+ goto scanNumber;
+ case 'd':
+ size = sizeof(double);
+ /* fall through */
+ scanNumber:
+ if (arg >= objc) {
+ goto badIndex;
+ }
+ if (count == BINARY_NOCOUNT) {
+ if ((length - offset) < size) {
+ goto done;
+ }
+ valuePtr = ScanNumber(buffer+offset, cmd);
+ offset += size;
+ } else {
+ if (count == BINARY_ALL) {
+ count = (length - offset) / size;
+ }
+ if ((length - offset) < (count * size)) {
+ goto done;
+ }
+ valuePtr = Tcl_NewObj();
+ str = buffer+offset;
+ for (i = 0; i < count; i++) {
+ elementPtr = ScanNumber(str, cmd);
+ str += size;
+ Tcl_ListObjAppendElement(NULL, valuePtr,
+ elementPtr);
+ }
+ offset += count*size;
+ }
+
+ resultPtr = Tcl_ObjSetVar2(interp, objv[arg++], NULL,
+ valuePtr,
+ TCL_LEAVE_ERR_MSG | TCL_PARSE_PART1);
+ if (resultPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* unneeded */
+ return TCL_ERROR;
+ }
+ break;
+ case 'x':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL)
+ || (count > (length - offset))) {
+ offset = length;
+ } else {
+ offset += count;
+ }
+ break;
+ case 'X':
+ if (count == BINARY_NOCOUNT) {
+ count = 1;
+ }
+ if ((count == BINARY_ALL) || (count > offset)) {
+ offset = 0;
+ } else {
+ offset -= count;
+ }
+ break;
+ case '@':
+ if (count == BINARY_NOCOUNT) {
+ goto badCount;
+ }
+ if ((count == BINARY_ALL) || (count > length)) {
+ offset = length;
+ } else {
+ offset = count;
+ }
+ break;
+ default: {
+ char buf[2];
+
+ Tcl_ResetResult(interp);
+ buf[0] = cmd;
+ buf[1] = '\0';
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "bad field specifier \"", buf, "\"", NULL);
+ return TCL_ERROR;
+ }
+ }
+ }
+
+ /*
+ * Set the result to the last position of the cursor.
+ */
+
+ done:
+ Tcl_ResetResult(interp);
+ Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
+ break;
+ }
+ }
+ return TCL_OK;
+
+ badValue:
+ Tcl_ResetResult(interp);
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "expected ", errorString,
+ " string but got \"", errorValue, "\" instead", NULL);
+ return TCL_ERROR;
+
+ badCount:
+ errorString = "missing count for \"@\" field specifier";
+ goto error;
+
+ badIndex:
+ errorString = "not enough arguments for all format specifiers";
+ goto error;
+
+ error:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), errorString, -1);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetFormatSpec --
+ *
+ * This function parses the format strings used in the binary
+ * format and scan commands.
+ *
+ * Results:
+ * Moves the formatPtr to the start of the next command. Returns
+ * the current command character and count in cmdPtr and countPtr.
+ * The count is set to BINARY_ALL if the count character was '*'
+ * or BINARY_NOCOUNT if no count was specified. Returns 1 on
+ * success, or 0 if the string did not have a format specifier.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetFormatSpec(formatPtr, cmdPtr, countPtr)
+ char **formatPtr; /* Pointer to format string. */
+ char *cmdPtr; /* Pointer to location of command char. */
+ int *countPtr; /* Pointer to repeat count value. */
+{
+ /*
+ * Skip any leading blanks.
+ */
+
+ while (**formatPtr == ' ') {
+ (*formatPtr)++;
+ }
+
+ /*
+ * The string was empty, except for whitespace, so fail.
+ */
+
+ if (!(**formatPtr)) {
+ return 0;
+ }
+
+ /*
+ * Extract the command character and any trailing digits or '*'.
+ */
+
+ *cmdPtr = **formatPtr;
+ (*formatPtr)++;
+ if (**formatPtr == '*') {
+ (*formatPtr)++;
+ (*countPtr) = BINARY_ALL;
+ } else if (isdigit(**formatPtr)) {
+ (*countPtr) = strtoul(*formatPtr, formatPtr, 10);
+ } else {
+ (*countPtr) = BINARY_NOCOUNT;
+ }
+ return 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FormatNumber --
+ *
+ * This routine is called by Tcl_BinaryObjCmd to format a number
+ * into a location pointed at by cursor.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Moves the cursor to the next location to be written into.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+FormatNumber(interp, type, src, cursorPtr)
+ Tcl_Interp *interp; /* Current interpreter, used to report
+ * errors. */
+ int type; /* Type of number to format. */
+ Tcl_Obj *src; /* Number to format. */
+ char **cursorPtr; /* Pointer to index into destination buffer. */
+{
+ int value;
+ double dvalue;
+ char cmd = (char)type;
+
+ if (cmd == 'd' || cmd == 'f') {
+ /*
+ * For floating point types, we need to copy the data using
+ * memcpy to avoid alignment issues.
+ */
+
+ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (cmd == 'd') {
+ memcpy((*cursorPtr), &dvalue, sizeof(double));
+ (*cursorPtr) += sizeof(double);
+ } else {
+ float fvalue;
+
+ /*
+ * Because some compilers will generate floating point exceptions
+ * on an overflow cast (e.g. Borland), we restrict the values
+ * to the valid range for float.
+ */
+
+ if (fabs(dvalue) > (double)FLT_MAX) {
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ } else {
+ fvalue = (float) dvalue;
+ }
+ memcpy((*cursorPtr), &fvalue, sizeof(float));
+ (*cursorPtr) += sizeof(float);
+ }
+ } else {
+ if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (cmd == 'c') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ } else if (cmd == 's') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ } else if (cmd == 'S') {
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ } else if (cmd == 'i') {
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
+ } else if (cmd == 'I') {
+ *(*cursorPtr)++ = (char)((value >> 24) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 16) & 0xff);
+ *(*cursorPtr)++ = (char)((value >> 8) & 0xff);
+ *(*cursorPtr)++ = (char)(value & 0xff);
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ScanNumber --
+ *
+ * This routine is called by Tcl_BinaryObjCmd to scan a number
+ * out of a buffer.
+ *
+ * Results:
+ * Returns a newly created object containing the scanned number.
+ * This object has a ref count of zero.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_Obj *
+ScanNumber(buffer, type)
+ char *buffer; /* Buffer to scan number from. */
+ int type; /* Format character from "binary scan" */
+{
+ int value;
+
+ /*
+ * We cannot rely on the compiler to properly sign extend integer values
+ * when we cast from smaller values to larger values because we don't know
+ * the exact size of the integer types. So, we have to handle sign
+ * extension explicitly by checking the high bit and padding with 1's as
+ * needed.
+ */
+
+ switch ((char) type) {
+ case 'c':
+ value = buffer[0];
+
+ if (value & 0x80) {
+ value |= -0x100;
+ }
+ return Tcl_NewLongObj((long)value);
+ case 's':
+ value = (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8));
+ goto shortValue;
+ case 'S':
+ value = (((unsigned char)buffer[1])
+ + ((unsigned char)buffer[0] << 8));
+ shortValue:
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
+ return Tcl_NewLongObj((long)value);
+ case 'i':
+ value = (((unsigned char)buffer[0])
+ + ((unsigned char)buffer[1] << 8)
+ + ((unsigned char)buffer[2] << 16)
+ + ((unsigned char)buffer[3] << 24));
+ goto intValue;
+ case 'I':
+ value = (((unsigned char)buffer[3])
+ + ((unsigned char)buffer[2] << 8)
+ + ((unsigned char)buffer[1] << 16)
+ + ((unsigned char)buffer[0] << 24));
+ intValue:
+ /*
+ * Check to see if the value was sign extended properly on
+ * systems where an int is more than 32-bits.
+ */
+
+ if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
+ value -= (((unsigned int)1)<<31);
+ value -= (((unsigned int)1)<<31);
+ }
+
+ return Tcl_NewLongObj((long)value);
+ case 'f': {
+ float fvalue;
+ memcpy(&fvalue, buffer, sizeof(float));
+ return Tcl_NewDoubleObj(fvalue);
+ }
+ case 'd': {
+ double dvalue;
+ memcpy(&dvalue, buffer, sizeof(double));
+ return Tcl_NewDoubleObj(dvalue);
+ }
+ }
+ return NULL;
+}
generated by cgit v0.12 at 2024-07-21 14:19:00 (GMT)