Attachment "1565751.patch" to
ticket [1565751fff]
added by
dgp
2006-10-02 23:34:40.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.29
diff -u -r1.29 tclBinary.c
--- generic/tclBinary.c 10 Aug 2006 12:15:30 -0000 1.29
+++ generic/tclBinary.c 2 Oct 2006 16:32:37 -0000
@@ -14,6 +14,7 @@
*/
#include "tclInt.h"
+#include "tclTomMath.h"
#include <math.h>
@@ -26,6 +27,13 @@
#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,9 +62,9 @@
Tcl_Obj *src, unsigned char **cursorPtr);
static void FreeByteArrayInternalRep(Tcl_Obj *objPtr);
static int GetFormatSpec(char **formatPtr, char *cmdPtr,
- int *countPtr);
+ int *countPtr, int *flagsPtr);
static Tcl_Obj * ScanNumber(unsigned char *buffer, int type,
- Tcl_HashTable **numberCachePtr);
+ int flags, Tcl_HashTable **numberCachePtr);
static int SetByteArrayFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void UpdateStringOfByteArray(Tcl_Obj *listPtr);
@@ -563,6 +571,7 @@
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,7 +617,8 @@
length = 0;
while (*format != '\0') {
str = format;
- if (!GetFormatSpec(&format, &cmd, &count)) {
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
break;
}
switch (cmd) {
@@ -770,7 +780,8 @@
cursor = buffer;
maxPos = cursor;
while (*format != 0) {
- if (!GetFormatSpec(&format, &cmd, &count)) {
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
break;
}
if ((count == 0) && (cmd != '@')) {
@@ -1028,7 +1039,8 @@
offset = 0;
while (*format != '\0') {
str = format;
- if (!GetFormatSpec(&format, &cmd, &count)) {
+ flags = 0;
+ if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
goto done;
}
switch (cmd) {
@@ -1240,7 +1252,7 @@
if ((length - offset) < size) {
goto done;
}
- valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr);
+ valuePtr = ScanNumber(buffer+offset, cmd, flags, &numberCachePtr);
offset += size;
} else {
if (count == BINARY_ALL) {
@@ -1252,7 +1264,7 @@
valuePtr = Tcl_NewObj();
src = buffer+offset;
for (i = 0; i < count; i++) {
- elementPtr = ScanNumber(src, cmd, &numberCachePtr);
+ elementPtr = ScanNumber(src, cmd, flags, &numberCachePtr);
src += size;
Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
}
@@ -1373,7 +1385,8 @@
GetFormatSpec(
char **formatPtr, /* Pointer to format string. */
char *cmdPtr, /* Pointer to location of command char. */
- int *countPtr) /* Pointer to repeat count value. */
+ int *countPtr, /* Pointer to repeat count value. */
+ int *flagsPtr) /* Pointer to field flags */
{
/*
* Skip any leading blanks.
@@ -1397,6 +1410,10 @@
*cmdPtr = **formatPtr;
(*formatPtr)++;
+ if (**formatPtr == 'u') {
+ (*formatPtr)++;
+ (*flagsPtr) |= BINARY_UNSIGNED;
+ }
if (**formatPtr == '*') {
(*formatPtr)++;
(*countPtr) = BINARY_ALL;
@@ -1778,6 +1795,7 @@
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,6 +1812,7 @@
* 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,8 +1825,10 @@
*/
value = buffer[0];
- if (value & 0x80) {
- value |= -0x100;
+ if (!(flags & BINARY_UNSIGNED)) {
+ if (value & 0x80) {
+ value |= -0x100;
+ }
}
goto returnNumericObject;
@@ -1824,8 +1845,10 @@
} else {
value = (long) (buffer[1] + (buffer[0] << 8));
}
- if (value & 0x8000) {
- value |= -0x10000;
+ if (!(flags & BINARY_UNSIGNED)) {
+ if (value & 0x8000) {
+ value |= -0x10000;
+ }
}
goto returnNumericObject;
@@ -1840,22 +1863,28 @@
value = (long) (buffer[0]
+ (buffer[1] << 8)
+ (buffer[2] << 16)
- + (buffer[3] << 24));
+ + (((long)buffer[3]) << 24));
} else {
value = (long) (buffer[3]
+ (buffer[2] << 8)
+ (buffer[1] << 16)
- + (buffer[0] << 24));
+ + (((long)buffer[0]) << 24));
}
/*
* 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 ((value & (((unsigned int)1)<<31)) && (value > 0)) {
- value -= (((unsigned int)1)<<31);
- value -= (((unsigned int)1)<<31);
+ 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,7 +1949,16 @@
| (((Tcl_WideUInt) buffer[1]) << 48)
| (((Tcl_WideUInt) buffer[0]) << 56);
}
- return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
+ 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 -u -r1.28 binary.test
--- tests/binary.test 5 Apr 2006 15:17:39 -0000 1.28
+++ tests/binary.test 2 Oct 2006 16:32:39 -0000
@@ -905,6 +905,30 @@
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,6 +969,22 @@
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,6 +1025,14 @@
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,6 +1073,18 @@
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,6 +1125,18 @@
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,6 +1456,26 @@
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,6 +1555,26 @@
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
