Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Artifact 07de1627dfb950af384d7c91a22c3fb73dd8a2bc:

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