1014 lines
24 KiB
C
1014 lines
24 KiB
C
/*
|
||
* 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;
|
||
}
|