Attachment "binary_flag.patch" to
ticket [1565751fff]
added by
patthoyts
2006-09-29 04:31:32.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.29
diff -c -r1.29 tclBinary.c
*** generic/tclBinary.c 10 Aug 2006 12:15:30 -0000 1.29
--- generic/tclBinary.c 28 Sep 2006 21:26:05 -0000
***************
*** 14,19 ****
--- 14,20 ----
*/
#include "tclInt.h"
+ #include "tclTomMath.h"
#include <math.h>
***************
*** 26,31 ****
--- 27,39 ----
#define BINARY_NOCOUNT -2 /* No count was specified in format. */
/*
+ * The following flags may be ORed together and returned by GetFormatSpec
+ */
+
+ #define BINARY_SIGNED 0 /* Field to be read as signed data */
+ #define BINARY_UNSIGNED 1 /* Field to be read as unsigned data */
+
+ /*
* The following defines the maximum number of different (integer) numbers
* placed in the object cache by 'binary scan' before it bails out and
* switches back to Plan A (creating a new object for each value.)
***************
*** 54,62 ****
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(char **formatPtr, char *cmdPtr,
! int *countPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
! Tcl_HashTable **numberCachePtr);
static int SetByteArrayFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void UpdateStringOfByteArray(Tcl_Obj *listPtr);
--- 62,70 ----
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(char **formatPtr, char *cmdPtr,
! int *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
! int flags, Tcl_HashTable **numberCachePtr);
static int SetByteArrayFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void UpdateStringOfByteArray(Tcl_Obj *listPtr);
***************
*** 563,568 ****
--- 571,577 ----
char cmd; /* Current format character. */
int count; /* Count associated with current format
* character. */
+ int flags; /* Format field flags */
char *format; /* Pointer to current position in format
* string. */
Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */
***************
*** 608,614 ****
length = 0;
while (*format != '\0') {
str = format;
! if (!GetFormatSpec(&format, &cmd, &count)) {
break;
}
switch (cmd) {
--- 617,624 ----
length = 0;
while (*format != '\0') {
str = format;
! flags = 0;
! if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
break;
}
switch (cmd) {
***************
*** 770,776 ****
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
! if (!GetFormatSpec(&format, &cmd, &count)) {
break;
}
if ((count == 0) && (cmd != '@')) {
--- 780,787 ----
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
! flags = 0;
! if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
break;
}
if ((count == 0) && (cmd != '@')) {
***************
*** 1028,1034 ****
offset = 0;
while (*format != '\0') {
str = format;
! if (!GetFormatSpec(&format, &cmd, &count)) {
goto done;
}
switch (cmd) {
--- 1039,1046 ----
offset = 0;
while (*format != '\0') {
str = format;
! flags = 0;
! if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
goto done;
}
switch (cmd) {
***************
*** 1240,1246 ****
if ((length - offset) < size) {
goto done;
}
! valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
--- 1252,1258 ----
if ((length - offset) < size) {
goto done;
}
! valuePtr = ScanNumber(buffer+offset, cmd, flags, &numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
***************
*** 1252,1258 ****
valuePtr = Tcl_NewObj();
src = buffer+offset;
for (i = 0; i < count; i++) {
! elementPtr = ScanNumber(src, cmd, &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
--- 1264,1270 ----
valuePtr = Tcl_NewObj();
src = buffer+offset;
for (i = 0; i < count; i++) {
! elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
***************
*** 1373,1379 ****
GetFormatSpec(
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.
--- 1385,1392 ----
GetFormatSpec(
char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
! int *countPtr, /* Pointer to repeat count value. */
! int *flagsPtr) /* Pointer to field flags */
{
/*
* Skip any leading blanks.
***************
*** 1397,1402 ****
--- 1410,1419 ----
*cmdPtr = **formatPtr;
(*formatPtr)++;
+ if (**formatPtr == 'u') {
+ (*formatPtr)++;
+ (*flagsPtr) |= BINARY_UNSIGNED;
+ }
if (**formatPtr == '*') {
(*formatPtr)++;
(*countPtr) = BINARY_ALL;
***************
*** 1778,1783 ****
--- 1795,1801 ----
ScanNumber(
unsigned char *buffer, /* Buffer to scan number from. */
int type, /* Format character from "binary scan" */
+ int flags, /* Format field flags */
Tcl_HashTable **numberCachePtrPtr)
/* Place to look for cache of scanned
* value objects, or NULL if too many
***************
*** 1794,1799 ****
--- 1812,1818 ----
* 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.
+ * This practice is disabled if the BINARY_UNSIGNED flag is set.
*/
switch (type) {
***************
*** 1806,1813 ****
*/
value = buffer[0];
! if (value & 0x80) {
! value |= -0x100;
}
goto returnNumericObject;
--- 1825,1834 ----
*/
value = buffer[0];
! if (!(flags & BINARY_UNSIGNED)) {
! if (value & 0x80) {
! value |= -0x100;
! }
}
goto returnNumericObject;
***************
*** 1824,1831 ****
} else {
value = (long) (buffer[1] + (buffer[0] << 8));
}
! if (value & 0x8000) {
! value |= -0x10000;
}
goto returnNumericObject;
--- 1845,1854 ----
} else {
value = (long) (buffer[1] + (buffer[0] << 8));
}
! if (!(flags & BINARY_UNSIGNED)) {
! if (value & 0x8000) {
! value |= -0x10000;
! }
}
goto returnNumericObject;
***************
*** 1851,1861 ****
/*
* 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);
}
returnNumericObject:
--- 1874,1890 ----
/*
* Check to see if the value was sign extended properly on systems
* where an int is more than 32-bits.
+ * We avoid caching unsigned integers as we cannot distinguish between
+ * 32bit signed and unsigned in the hash (short and char are ok).
*/
! if ((flags & BINARY_UNSIGNED)) {
! return Tcl_NewWideIntObj((unsigned long)value);
! } else {
! if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
! value -= (((unsigned int)1)<<31);
! value -= (((unsigned int)1)<<31);
! }
}
returnNumericObject:
***************
*** 1920,1926 ****
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
}
! return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
/*
* Do not cache double values; they are already too large to use as
--- 1949,1964 ----
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
}
! if (flags & BINARY_UNSIGNED) {
! Tcl_Obj *bigObj = NULL;
! mp_int big;
!
! TclBNInitBignumFromWideUInt(&big, uwvalue);
! bigObj = Tcl_NewBignumObj(&big);
! return bigObj;
! } else {
! return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
! }
/*
* Do not cache double values; they are already too large to use as
Index: tests/binary.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/binary.test,v
retrieving revision 1.28
diff -c -r1.28 binary.test
*** tests/binary.test 5 Apr 2006 15:17:39 -0000 1.28
--- tests/binary.test 28 Sep 2006 21:26:06 -0000
***************
*** 905,910 ****
--- 905,934 ----
set arg2 bar
list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2
} {2 {112 -121} 5}
+ test binary-26.11 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 cu* arg1] $arg1
+ } {1 {82 163}}
+ test binary-26.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 cu arg1] $arg1
+ } {1 82}
+ test binary-26.13 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \xff cu arg1] $arg1
+ } {1 255}
+ test binary-26.14 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x80\x80 cuc arg1 arg2] $arg1 $arg2
+ } {2 128 -128}
+ test binary-26.15 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x80\x80 ccu arg1 arg2] $arg1 $arg2
+ } {2 -128 128}
test binary-27.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc s} msg] $msg
***************
*** 945,950 ****
--- 969,990 ----
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}
+ test binary-27.10 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 su* arg1] $arg1
+ } {1 {41810 21587}}
+ test binary-27.11 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \xff\xff\xff\xff sus arg1 arg2] $arg1 $arg2
+ } {2 65535 -1}
+ test binary-27.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \xff\xff\xff\xff ssu arg1 arg2] $arg1 $arg2
+ } {2 -1 65535}
test binary-28.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc S} msg] $msg
***************
*** 985,990 ****
--- 1025,1038 ----
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}
+ test binary-28.10 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 Su* arg1] $arg1
+ } {1 {21155 21332}}
+ test binary-28.11 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ list [binary scan \xa3\x52\x54\x53 Su* arg1] $arg1
+ } {1 {41810 21587}}
test binary-29.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc i} msg] $msg
***************
*** 1025,1030 ****
--- 1073,1090 ----
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 i2c* arg1 arg2] $arg1 $arg2
} {2 {1414767442 67305985} 5}
+ test binary-29.10 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iui arg1 arg2] $arg1 $arg2
+ } {2 4294967295 -1}
+ test binary-29.11 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff iiu arg1 arg2] $arg1 $arg2
+ } {2 -1 4294967295}
+ test binary-29.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 iuiu arg1 arg2] $arg1 $arg2
+ } {2 128 2147483648}
test binary-30.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc I} msg] $msg
***************
*** 1065,1070 ****
--- 1125,1142 ----
set arg2 bar
list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 I2c* arg1 arg2] $arg1 $arg2
} {2 {1386435412 16909060} 5}
+ test binary-30.10 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IuI arg1 arg2] $arg1 $arg2
+ } {2 4294967295 -1}
+ test binary-30.11 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \xff\xff\xff\xff\xff\xff\xff\xff IIu arg1 arg2] $arg1 $arg2
+ } {2 -1 4294967295}
+ test binary-30.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1 arg2}
+ list [binary scan \x80\x00\x00\x00\x00\x00\x00\x80 IuIu arg1 arg2] $arg1 $arg2
+ } {2 2147483648 128}
test binary-31.1 {Tcl_BinaryObjCmd: scan} {
list [catch {binary scan abc f} msg] $msg
***************
*** 1384,1389 ****
--- 1456,1481 ----
catch {unset arg1}
list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}
+ test binary-39.6 {ScanNumber: no sign extension} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 cu2 arg1] $arg1
+ } {1 {82 163}}
+ test binary-39.7 {ScanNumber: no sign extension} {
+ catch {unset arg1}
+ list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 su4 arg1] $arg1
+ } {1 {513 33025 386 33409}}
+ test binary-39.8 {ScanNumber: no sign extension} {
+ catch {unset arg1}
+ list [binary scan \x01\x02\x01\x81\x82\x01\x81\x82 Su4 arg1] $arg1
+ } {1 {258 385 33281 33154}}
+ test binary-39.9 {ScanNumber: no sign extension} {
+ catch {unset arg1}
+ list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 iu5 arg1] $arg1
+ } {1 {33620225 16843137 16876033 25297153 2164326657}}
+ test binary-39.10 {ScanNumber: no sign extension} {
+ catch {unset arg1}
+ list [binary scan \x01\x01\x01\x02\x81\x01\x01\x01\x01\x82\x01\x01\x01\x01\x82\x01\x01\x01\x01\x81 Iu5 arg1] $arg1
+ } {1 {16843010 2164326657 25297153 16876033 16843137}}
test binary-40.3 {ScanNumber: NaN} \
-body {
***************
*** 1463,1468 ****
--- 1555,1580 ----
binary scan [binary format W [expr {wide(3) << 31}]] W x
set x
} 6442450944
+ test binary-43.5 {Tcl_BinaryObjCmd: scan wide int} {} {
+ catch {unset arg1}
+ list [binary scan \x80[string repeat \x00 7] W arg1] $arg1
+ } {1 -9223372036854775808}
+ test binary-43.6 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+ catch {unset arg1}
+ list [binary scan \x80[string repeat \x00 7] Wu arg1] $arg1
+ } {1 9223372036854775808}
+ test binary-43.7 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+ catch {unset arg1}
+ list [binary scan [string repeat \x00 7]\x80 wu arg1] $arg1
+ } {1 9223372036854775808}
+ test binary-43.8 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+ catch {unset arg1 arg2}
+ list [binary scan \x80[string repeat \x00 7]\x80[string repeat \x00 7] WuW arg1 arg2] $arg1 $arg2
+ } {2 9223372036854775808 -9223372036854775808}
+ test binary-43.9 {Tcl_BinaryObjCmd: scan unsigned wide int} {} {
+ catch {unset arg1 arg2}
+ list [binary scan [string repeat \x00 7]\x80[string repeat \x00 7]\x80 wuw arg1 arg2] $arg1 $arg2
+ } {2 9223372036854775808 -9223372036854775808}
test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
binary scan [binary format sws 16450 -1 19521] c* x
