Attachment "tip129.patch" to
ticket [858211ffff]
added by
mrohr
2003-12-11 18:59:17.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.14
diff -u -r1.14 tclBinary.c
--- generic/tclBinary.c 2 Dec 2003 09:29:54 -0000 1.14
+++ generic/tclBinary.c 11 Dec 2003 11:48:11 -0000
@@ -656,25 +656,32 @@
size = 1;
goto doNumbers;
}
+ case 't':
case 's':
case 'S': {
size = 2;
goto doNumbers;
}
+ case 'n':
case 'i':
case 'I': {
size = 4;
goto doNumbers;
}
+ case 'm':
case 'w':
case 'W': {
size = 8;
goto doNumbers;
}
+ case 'r':
+ case 'R':
case 'f': {
size = sizeof(float);
goto doNumbers;
}
+ case 'q':
+ case 'Q':
case 'd': {
size = sizeof(double);
@@ -703,7 +710,7 @@
if (count == BINARY_ALL) {
count = listc;
} else if (count > listc) {
- Tcl_AppendResult(interp,
+ Tcl_AppendResult(interp,
"number of elements in list does not match count",
(char *) NULL);
return TCL_ERROR;
@@ -752,7 +759,7 @@
}
default: {
errorString = str;
- goto badField;
+ goto badfield;
}
}
}
@@ -810,7 +817,7 @@
memcpy((VOID *) cursor, (VOID *) bytes,
(size_t) length);
memset((VOID *) (cursor + length), pad,
- (size_t) (count - length));
+ (size_t) (count - length));
}
cursor += count;
break;
@@ -953,6 +960,13 @@
case 'I':
case 'w':
case 'W':
+ case 'q':
+ case 'Q':
+ case 'r':
+ case 'R':
+ case 't':
+ case 'm':
+ case 'n':
case 'd':
case 'f': {
int listc, i;
@@ -1209,24 +1223,31 @@
goto scanNumber;
}
case 's':
+ case 't':
case 'S': {
size = 2;
goto scanNumber;
}
case 'i':
+ case 'n':
case 'I': {
size = 4;
goto scanNumber;
}
case 'w':
+ case 'm':
case 'W': {
size = 8;
goto scanNumber;
}
+ case 'r':
+ case 'R':
case 'f': {
size = sizeof(float);
goto scanNumber;
}
+ case 'q':
+ case 'Q':
case 'd': {
unsigned char *src;
@@ -1312,7 +1333,7 @@
default: {
DeleteScanNumberCache(numberCachePtr);
errorString = str;
- goto badField;
+ goto badfield;
}
}
}
@@ -1344,8 +1365,7 @@
errorString = "not enough arguments for all format specifiers";
goto error;
- badField:
- {
+ badfield: {
Tcl_UniChar ch;
char buf[TCL_UTF_MAX + 1];
@@ -1421,6 +1441,129 @@
}
/*
+ * ---------------------------------------------------------------------
+ *
+ * NeedReversion --
+ *
+ * This routine determines, if bytes of a number need to be reversed. This
+ * depends on the endiannes of the machine and the desired format.
+ *
+ * Results:
+ * int: 1 if reversion is required, 0 if not.
+ *
+ * Side effects:
+ * None
+ *
+ * ---------------------------------------------------------------------
+ */
+static int
+NeedReversion( format )
+ int format;
+{
+ static int testDummy = 0x01;
+ int bBigEndian;
+
+ // last byte is 1 => big endian.
+ bBigEndian = (((unsigned char*)&testDummy)[sizeof(testDummy)-1])==1;
+
+ switch( format )
+ {
+ // native floats and doubles: no
+ case 'd':
+ case 'f':
+ return 0;
+
+ // native ints:
+ case 'n':
+ case 't':
+ case 'm':
+ return bBigEndian ? 0 : 1;
+
+ // f+d
+ case 'Q':
+ case 'R':
+ return bBigEndian ? 0 : 1;
+
+ // big endian ints
+ case 'I':
+ case 'S':
+ case 'W':
+ return 0;
+
+ // small endian floats
+ case 'q':
+ case 'r':
+ return bBigEndian ? 1 : 0;
+
+ // small endian ints
+ case 'i':
+ case 's':
+ case 'w':
+ return 1;
+
+ default:
+ // we never come here
+ // assert(0);
+ return 0;
+ }
+}
+
+/*
+ * ---------------------------------------------------------------------
+ *
+ * CopyNumber --
+ *
+ * This routine is called by FormatNumer and ScanNumber to copy a number.
+ * If required, bytes are reversed while copying
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * Copies length bytes
+
+ * ---------------------------------------------------------------------
+ */
+static void
+CopyNumber( from, to, length, reverse )
+ unsigned char *from; /* source */
+ unsigned char *to; /* destination */
+ int length; /* Number of bytes to copy */
+ int reverse; /* if true, reverse order while copying */
+{
+ if( reverse )
+ {
+ switch( length )
+ {
+ case 2:
+ to[0]=from[1];
+ to[1]=from[0];
+ break;
+ case 4:
+ to[0]=from[3];
+ to[1]=from[2];
+ to[2]=from[1];
+ to[3]=from[0];
+ break;
+ case 8:
+ to[0]=from[7];
+ to[1]=from[6];
+ to[2]=from[5];
+ to[3]=from[4];
+ to[4]=from[3];
+ to[5]=from[2];
+ to[6]=from[1];
+ to[7]=from[0];
+ break;
+ }
+ }
+ else
+ {
+ memcpy( to, from, length );
+ }
+}
+
+/*
*----------------------------------------------------------------------
*
* FormatNumber --
@@ -1448,38 +1591,40 @@
long value;
double dvalue;
Tcl_WideInt wvalue;
-
+ float fvalue;
switch (type) {
- case 'd':
- case 'f':
- /*
- * For floating point types, we need to copy the data using
- * memcpy to avoid alignment issues.
- */
+ // double
+ case 'd':
+ case 'q':
+ case 'Q':
+ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ CopyNumber( &dvalue, *cursorPtr, sizeof(double), NeedReversion(type) );
+ *cursorPtr += sizeof(double);
+ return TCL_OK;
+ // float
+ case 'f':
+ case 'r':
+ case 'R':
if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
return TCL_ERROR;
}
- if (type == 'd') {
- memcpy((VOID *) *cursorPtr, (VOID *) &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.
- */
+ /*
+ * 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((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
- *cursorPtr += sizeof(float);
+ if (fabs(dvalue) > (double)FLT_MAX) {
+ fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ } else {
+ fvalue = (float) dvalue;
}
+ CopyNumber( &fvalue, *cursorPtr, sizeof(float), NeedReversion(type) );
+ *cursorPtr += sizeof(float);
return TCL_OK;
/*
@@ -1488,10 +1633,11 @@
*/
case 'w':
case 'W':
+ case 'm':
if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
return TCL_ERROR;
}
- if (type == 'w') {
+ if( NeedReversion(type) ) {
*(*cursorPtr)++ = (unsigned char) wvalue;
*(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
*(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
@@ -1511,29 +1657,52 @@
*(*cursorPtr)++ = (unsigned char) wvalue;
}
return TCL_OK;
- default:
- if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
- return TCL_ERROR;
- }
- if (type == 'c') {
- *(*cursorPtr)++ = (unsigned char) value;
- } else if (type == 's') {
- *(*cursorPtr)++ = (unsigned char) value;
+
+ // short
+ case 's':
+ case 'S':
+ case 't':
+ if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if( NeedReversion(type) ) {
+ *(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
- } else if (type == 'S') {
+ } else {
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
- } else if (type == 'i') {
+ }
+ return TCL_OK;
+
+ // long
+ case 'i':
+ case 'I':
+ case 'n':
+ if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if( NeedReversion(type) ) {
*(*cursorPtr)++ = (unsigned char) value;
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 24);
- } else if (type == 'I') {
+ } else {
*(*cursorPtr)++ = (unsigned char) (value >> 24);
*(*cursorPtr)++ = (unsigned char) (value >> 16);
*(*cursorPtr)++ = (unsigned char) (value >> 8);
*(*cursorPtr)++ = (unsigned char) value;
- }
+ }
+ return TCL_OK;
+
+ case 'c':
+ if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *(*cursorPtr)++ = (unsigned char) value;
+ return TCL_OK;
+
+ default:
+ //assert(0);
return TCL_OK;
}
}
@@ -1592,40 +1761,43 @@
value |= -0x100;
}
goto returnNumericObject;
-
- case 's':
- value = (long) (buffer[0] + (buffer[1] << 8));
- goto shortValue;
+
+ /* shorts */
+ case 't':
case 'S':
- value = (long) (buffer[1] + (buffer[0] << 8));
- shortValue:
- if (value & 0x8000) {
+ case 's':
+ if( NeedReversion(type) ) {
+ value = (long) (buffer[0] + (buffer[1] << 8));
+ } else {
+ value = (long) (buffer[1] + (buffer[0] << 8));
+ }
+ if (value & 0x8000) {
value |= -0x10000;
}
goto returnNumericObject;
-
+
+ /* int4 */
case 'i':
- value = (long) (buffer[0]
- + (buffer[1] << 8)
- + (buffer[2] << 16)
- + (buffer[3] << 24));
- goto intValue;
case 'I':
- value = (long) (buffer[3]
- + (buffer[2] << 8)
- + (buffer[1] << 16)
- + (buffer[0] << 24));
- intValue:
- /*
- * Check to see if the value was sign extended properly on
- * systems where an int is more than 32-bits.
- */
-
+ case 'n':
+ if( NeedReversion(type) ) {
+ value = (long) (buffer[0]
+ + (buffer[1] << 8)
+ + (buffer[2] << 16)
+ + (buffer[3] << 24));
+ } else {
+ value = (long) (buffer[3]
+ + (buffer[2] << 8)
+ + (buffer[1] << 16)
+ + (buffer[0] << 24));
+ }
if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
value -= (((unsigned int)1)<<31);
value -= (((unsigned int)1)<<31);
- }
- returnNumericObject:
+ }
+
+ returnNumericObject:
+
if (*numberCachePtrPtr == NULL) {
return Tcl_NewLongObj(value);
} else {
@@ -1659,12 +1831,16 @@
}
}
- /*
- * Do not cache wide values; they are already too large to
- * use as keys.
- */
+
+ /*
+ * Do not cache wide values; they are already too large to
+ * use as keys.
+ */
+ case 'm':
case 'w':
- uwvalue = ((Tcl_WideUInt) buffer[0])
+ case 'W':
+ if( NeedReversion(type) ) {
+ uwvalue = ((Tcl_WideUInt) buffer[0])
| (((Tcl_WideUInt) buffer[1]) << 8)
| (((Tcl_WideUInt) buffer[2]) << 16)
| (((Tcl_WideUInt) buffer[3]) << 24)
@@ -1672,9 +1848,8 @@
| (((Tcl_WideUInt) buffer[5]) << 40)
| (((Tcl_WideUInt) buffer[6]) << 48)
| (((Tcl_WideUInt) buffer[7]) << 56);
- return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
- case 'W':
- uwvalue = ((Tcl_WideUInt) buffer[7])
+ } else {
+ uwvalue = ((Tcl_WideUInt) buffer[7])
| (((Tcl_WideUInt) buffer[6]) << 8)
| (((Tcl_WideUInt) buffer[5]) << 16)
| (((Tcl_WideUInt) buffer[4]) << 24)
@@ -1682,23 +1857,33 @@
| (((Tcl_WideUInt) buffer[2]) << 40)
| (((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 keys and the values stored are utterly
- * incompatible too.
- */
- case 'f': {
- float fvalue;
- memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
- return Tcl_NewDoubleObj(fvalue);
- }
- case 'd': {
- double dvalue;
- memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
- return Tcl_NewDoubleObj(dvalue);
- }
+ /*
+ * Do not cache double values; they are already too large
+ * to use as keys and the values stored are utterly
+ * incompatible too.
+ */
+ /* float's */
+ case 'f':
+ case 'R':
+ case 'r': {
+ float fvalue;
+ CopyNumber( buffer, &fvalue, sizeof(float), NeedReversion(type) );
+ return Tcl_NewDoubleObj(fvalue);
+ }
+
+ /* doubles's */
+ case 'd':
+ case 'Q':
+ case 'q': {
+ double dvalue;
+ CopyNumber( buffer, &dvalue, sizeof(double), NeedReversion(type) );
+ return Tcl_NewDoubleObj(dvalue);
+ }
+
}
return NULL;
}
Index: tests/binary.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/binary.test,v
retrieving revision 1.13
diff -u -r1.13 binary.test
--- tests/binary.test 2 Dec 2003 09:29:54 -0000 1.13
+++ tests/binary.test 11 Dec 2003 11:48:16 -0000
@@ -1524,6 +1524,585 @@
list [binary scan aba ccc x x x] $x
} {3 97}
+# format t
+test binary-48.1 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format t} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-48.2 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format t blat} msg] $msg
+} {1 {expected integer but got "blat"}}
+test binary-48.3 {Tcl_BinaryObjCmd: format} {
+ binary format S0 0x50
+} {}
+test binary-48.4 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t 0x50
+} \x00P
+test binary-48.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t 0x50
+} P\x00
+test binary-48.6 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t 0x5052
+} PR
+test binary-48.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t 0x5052
+} RP
+test binary-48.8 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t 0x505251 0x53
+} RQ
+test binary-48.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t 0x505251 0x53
+} QR
+test binary-48.10 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t2 {0x50 0x52}
+} \x00P\x00R
+test binary-48.11 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t2 {0x50 0x52}
+} P\x00R\x00
+test binary-48.12 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t* {0x5051 0x52}
+} PQ\x00R
+test binary-48.13 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t* {0x5051 0x52}
+} QPR\x00
+test binary-48.14 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format t2 {0x50 0x52 0x53} 0x54
+} \x00P\x00R
+test binary-48.15 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format t2 {0x50 0x52 0x53} 0x54
+} P\x00R\x00
+test binary-48.16 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format t2 {0x50}} msg] $msg
+} {1 {number of elements in list does not match count}}
+test binary-48.17 {Tcl_BinaryObjCmd: format} {
+ set a {0x50 0x51}
+ list [catch {binary format t $a} msg] $msg
+} [list 1 "expected integer but got \"0x50 0x51\""]
+test binary-48.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ set a {0x50 0x51}
+ binary format t1 $a
+} \x00P
+test binary-48.18 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ set a {0x50 0x51}
+ binary format t1 $a
+} P\x00
+
+# format n
+test binary-49.1 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format n} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-49.2 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format n blat} msg] $msg
+} {1 {expected integer but got "blat"}}
+test binary-49.3 {Tcl_BinaryObjCmd: format} {
+ binary format n0 0x50
+} {}
+test binary-49.4 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n 0x50
+} P\x00\x00\x00
+test binary-49.5 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n 0x5052
+} RP\x00\x00
+test binary-49.6 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n 0x505251 0x53
+} QRP\x00
+test binary-49.7 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format i1 {0x505251 0x53}
+} QRP\x00
+test binary-49.8 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n 0x53525150
+} PQRS
+test binary-49.9 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n2 {0x50 0x52}
+} P\x00\x00\x00R\x00\x00\x00
+test binary-49.10 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ binary format n* {0x50515253 0x52}
+} SRQPR\x00\x00\x00
+test binary-49.11 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format n2 {0x50}} msg] $msg
+} {1 {number of elements in list does not match count}}
+test binary-49.12 {Tcl_BinaryObjCmd: format} {
+ set a {0x50 0x51}
+ list [catch {binary format n $a} msg] $msg
+} [list 1 "expected integer but got \"0x50 0x51\""]
+test binary-49.13 {Tcl_BinaryObjCmd: format} {nonPortable pcOnly} {
+ set a {0x50 0x51}
+ binary format n1 $a
+} P\x00\x00\x00
+test binary-49.14 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n 0x50
+} \x00\x00\x00P
+test binary-49.15 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n 0x5052
+} \x00\x00PR
+test binary-49.16 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n 0x505251 0x53
+} \x00PRQ
+test binary-49.17 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format i1 {0x505251 0x53}
+} QRP\x00
+test binary-49.18 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n 0x53525150
+} SRQP
+test binary-49.19 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n2 {0x50 0x52}
+} \x00\x00\x00P\x00\x00\x00R
+test binary-49.20 {Tcl_BinaryObjCmd: format} {nonPortable macOrUnix} {
+ binary format n* {0x50515253 0x52}
+} PQRS\x00\x00\x00R
+
+# format m
+test binary-50.1 {Tcl_BinaryObjCmd: format wide int} {nonPortable pcOnly} {
+ binary format m 7810179016327718216
+} HelloTcl
+test binary-50.2 {Tcl_BinaryObjCmd: format wide int} {nonPortable macOrUnix} {
+ binary format m 7810179016327718216
+} lcTolleH
+test binary-50.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {nonPortable pcOnly} {
+ binary scan [binary format m [expr {wide(3) << 31}]] w x
+ set x
+} 6442450944
+test binary-50.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {nonPortable macOrUnix} {
+ binary scan [binary format m [expr {wide(3) << 31}]] W x
+ set x
+} 6442450944
+
+
+# format Q/q
+test binary-51.1 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format Q} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-51.2 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format q blat} msg] $msg
+} {1 {expected floating-point number but got "blat"}}
+test binary-51.3 {Tcl_BinaryObjCmd: format} {
+ binary format q0 1.6
+} {}
+test binary-51.4 {Tcl_BinaryObjCmd: format} {} {
+ binary format Q 1.6
+} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+test binary-51.5 {Tcl_BinaryObjCmd: format} {} {
+ binary format q 1.6
+} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+test binary-51.6 {Tcl_BinaryObjCmd: format} {} {
+ binary format Q* {1.6 3.4}
+} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+test binary-51.7 {Tcl_BinaryObjCmd: format} {} {
+ binary format q* {1.6 3.4}
+} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+test binary-51.8 {Tcl_BinaryObjCmd: format} {} {
+ binary format Q2 {1.6 3.4}
+} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+test binary-51.9 {Tcl_BinaryObjCmd: format} {} {
+ binary format q2 {1.6 3.4}
+} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+test binary-51.10 {Tcl_BinaryObjCmd: format} {} {
+ binary format Q2 {1.6 3.4 5.6}
+} \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33
+test binary-51.11 {Tcl_BinaryObjCmd: format} {} {
+ binary format q2 {1.6 3.4 5.6}
+} \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40
+#test binary-51.12 {Tcl_BinaryObjCmd: float overflow} {nonPortable unixOnly} {
+# binary format d NaN
+#} \x7f\xff\xff\xff\xff\xff\xff\xff
+#test binary-51.13 {Tcl_BinaryObjCmd: float overflow} {nonPortable macOnly} {
+# binary format d NaN
+#} \x7f\xf8\x02\xa0\x00\x00\x00\x00
+test binary-51.14 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format q2 {1.6}} msg] $msg
+} {1 {number of elements in list does not match count}}
+test binary-51.15 {Tcl_BinaryObjCmd: format} {
+ set a {1.6 3.4}
+ list [catch {binary format q $a} msg] $msg
+} [list 1 "expected floating-point number but got \"1.6 3.4\""]
+test binary-51.16 {Tcl_BinaryObjCmd: format} {} {
+ set a {1.6 3.4}
+ binary format Q1 $a
+} \x3f\xf9\x99\x99\x99\x99\x99\x9a
+test binary-51.17 {Tcl_BinaryObjCmd: format} {} {
+ set a {1.6 3.4}
+ binary format q1 $a
+} \x9a\x99\x99\x99\x99\x99\xf9\x3f
+
+# format R/r
+test binary-53.1 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format r} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-53.2 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format r blat} msg] $msg
+} {1 {expected floating-point number but got "blat"}}
+test binary-53.3 {Tcl_BinaryObjCmd: format} {
+ binary format f0 1.6
+} {}
+test binary-53.4 {Tcl_BinaryObjCmd: format} {} {
+ binary format R 1.6
+} \x3f\xcc\xcc\xcd
+test binary-53.5 {Tcl_BinaryObjCmd: format} {} {
+ binary format r 1.6
+} \xcd\xcc\xcc\x3f
+test binary-53.6 {Tcl_BinaryObjCmd: format} {} {
+ binary format R* {1.6 3.4}
+} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+test binary-53.7 {Tcl_BinaryObjCmd: format} {} {
+ binary format r* {1.6 3.4}
+} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+test binary-53.8 {Tcl_BinaryObjCmd: format} {} {
+ binary format R2 {1.6 3.4}
+} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+test binary-53.9 {Tcl_BinaryObjCmd: format} {} {
+ binary format r2 {1.6 3.4}
+} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+test binary-53.10 {Tcl_BinaryObjCmd: format} {} {
+ binary format R2 {1.6 3.4 5.6}
+} \x3f\xcc\xcc\xcd\x40\x59\x99\x9a
+test binary-53.11 {Tcl_BinaryObjCmd: format} {} {
+ binary format r2 {1.6 3.4 5.6}
+} \xcd\xcc\xcc\x3f\x9a\x99\x59\x40
+test binary-53.12 {Tcl_BinaryObjCmd: float overflow} {} {
+ binary format R -3.402825e+38
+} \xff\x7f\xff\xff
+test binary-53.13 {Tcl_BinaryObjCmd: float overflow} {} {
+ binary format r -3.402825e+38
+} \xff\xff\x7f\xff
+test binary-53.14 {Tcl_BinaryObjCmd: float underflow} {} {
+ binary format R -3.402825e-100
+} \x80\x00\x00\x00
+test binary-53.15 {Tcl_BinaryObjCmd: float underflow} {} {
+ binary format r -3.402825e-100
+} \x00\x00\x00\x80
+test binary-53.16 {Tcl_BinaryObjCmd: format} {
+ list [catch {binary format r2 {1.6}} msg] $msg
+} {1 {number of elements in list does not match count}}
+test binary-53.17 {Tcl_BinaryObjCmd: format} {
+ set a {1.6 3.4}
+ list [catch {binary format r $a} msg] $msg
+} [list 1 "expected floating-point number but got \"1.6 3.4\""]
+test binary-53.18 {Tcl_BinaryObjCmd: format} {} {
+ set a {1.6 3.4}
+ binary format R1 $a
+} \x3f\xcc\xcc\xcd
+test binary-53.19 {Tcl_BinaryObjCmd: format} {} {
+ set a {1.6 3.4}
+ binary format r1 $a
+} \xcd\xcc\xcc\x3f
+
+# scan t (s)
+test binary-54.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc t} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-54.2 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
+} {1 {-23726 21587}}
+test binary-54.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
+} {1 -23726}
+test binary-54.4 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 t1 arg1] $arg1
+} {1 -23726}
+test binary-54.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 t0 arg1] $arg1
+} {1 {}}
+test binary-54.6 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
+} {1 {-23726 21587}}
+test binary-54.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 t1 arg1] $arg1
+} {0 foo}
+test binary-54.8 {Tcl_BinaryObjCmd: scan} {} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x52\x53 t1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-54.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
+} {2 {-23726 21587} 5}
+
+# scan t (b)
+test binary-55.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc t} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-55.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t* arg1] $arg1
+} {1 {21155 21332}}
+test binary-55.3 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t arg1] $arg1
+} {1 21155}
+test binary-55.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 t1 arg1] $arg1
+} {1 21155}
+test binary-55.5 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3 t0 arg1] $arg1
+} {1 {}}
+test binary-55.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 t2 arg1] $arg1
+} {1 {21155 21332}}
+test binary-55.7 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 t1 arg1] $arg1
+} {0 foo}
+test binary-55.8 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x52\x53 t1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-55.9 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x52\xa3\x53\x54\x05 t2c* arg1 arg2] $arg1 $arg2
+} {2 {21155 21332} 5}
+
+# scan n (s)
+test binary-56.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc n} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-56.2 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
+} {1 {1414767442 67305985}}
+test binary-56.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
+} {1 1414767442}
+test binary-56.4 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
+} {1 1414767442}
+test binary-56.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53 n0 arg1] $arg1
+} {1 {}}
+test binary-56.6 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
+} {1 {1414767442 67305985}}
+test binary-56.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 n1 arg1] $arg1
+} {0 foo}
+test binary-56.8 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x52\x53\x53\x54 n1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-56.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
+} {2 {1414767442 67305985} 5}
+
+# scan n (b)
+test binary-57.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc n} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-57.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n* arg1] $arg1
+} {1 {1386435412 16909060}}
+test binary-57.3 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n arg1] $arg1
+} {1 1386435412}
+test binary-57.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54 n1 arg1] $arg1
+} {1 1386435412}
+test binary-57.5 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53 n0 arg1] $arg1
+} {1 {}}
+test binary-57.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 n2 arg1] $arg1
+} {1 {1386435412 16909060}}
+test binary-57.7 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 n1 arg1] $arg1
+} {0 foo}
+test binary-57.8 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x52\x53\x53\x54 n1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-57.9 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04\x05 n2c* arg1 arg2] $arg1 $arg2
+} {2 {1386435412 16909060} 5}
+
+# scan m
+test binary-60.1 {Tcl_BinaryObjCmd: scan wide int} {nonPortable macOrUnix} {
+ binary scan HelloTcl m x
+ set x
+} 5216694956358656876
+test binary-60.2 {Tcl_BinaryObjCmd: scan wide int} {nonPortable pcOnly} {
+ binary scan lcTolleH m x
+ set x
+} 5216694956358656876
+test binary-60.3 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {nonPortable pcOnly} {
+ binary scan [binary format w [expr {wide(3) << 31}]] m x
+ set x
+} 6442450944
+test binary-60.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {nonPortable macOrUnix} {
+ binary scan [binary format W [expr {wide(3) << 31}]] m x
+ set x
+} 6442450944
+
+
+# scan Q/q
+test binary-58.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc q} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-58.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q* arg1] $arg1
+} {1 {1.6 3.4}}
+test binary-58.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q* arg1] $arg1
+} {1 {1.6 3.4}}
+test binary-58.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q arg1] $arg1
+} {1 1.6}
+test binary-58.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q arg1] $arg1
+} {1 1.6}
+test binary-58.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q1 arg1] $arg1
+} {1 1.6}
+test binary-58.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q1 arg1] $arg1
+} {1 1.6}
+test binary-58.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a Q0 arg1] $arg1
+} {1 {}}
+test binary-58.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f q0 arg1] $arg1
+} {1 {}}
+test binary-58.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33 Q2 arg1] $arg1
+} {1 {1.6 3.4}}
+test binary-58.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40 q2 arg1] $arg1
+} {1 {1.6 3.4}}
+test binary-58.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 q1 arg1] $arg1
+} {0 foo}
+test binary-58.13 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a q1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-58.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x3f\xf9\x99\x99\x99\x99\x99\x9a\x40\x0b\x33\x33\x33\x33\x33\x33\x05 Q2c* arg1 arg2] $arg1 $arg2
+} {2 {1.6 3.4} 5}
+test binary-58.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x9a\x99\x99\x99\x99\x99\xf9\x3f\x33\x33\x33\x33\x33\x33\x0b\x40\x05 q2c* arg1 arg2] $arg1 $arg2
+} {2 {1.6 3.4} 5}
+
+
+# scan R/r
+test binary-59.1 {Tcl_BinaryObjCmd: scan} {
+ list [catch {binary scan abc r} msg] $msg
+} {1 {not enough arguments for all format specifiers}}
+test binary-59.2 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R* arg1] $arg1
+} {1 {1.60000002384 3.40000009537}}
+test binary-59.3 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r* arg1] $arg1
+} {1 {1.60000002384 3.40000009537}}
+test binary-59.4 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R arg1] $arg1
+} {1 1.60000002384}
+test binary-59.5 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r arg1] $arg1
+} {1 1.60000002384}
+test binary-59.6 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xcc\xcc\xcd R1 arg1] $arg1
+} {1 1.60000002384}
+test binary-59.7 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \xcd\xcc\xcc\x3f r1 arg1] $arg1
+} {1 1.60000002384}
+test binary-59.8 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xcc\xcc\xcd R0 arg1] $arg1
+} {1 {}}
+test binary-59.9 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \xcd\xcc\xcc\x3f r0 arg1] $arg1
+} {1 {}}
+test binary-59.10 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1}
+ list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a R2 arg1] $arg1
+} {1 {1.60000002384 3.40000009537}}
+test binary-59.11 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1}
+ list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40 r2 arg1] $arg1
+} {1 {1.60000002384 3.40000009537}}
+test binary-59.12 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 foo
+ list [binary scan \x52 r1 arg1] $arg1
+} {0 foo}
+test binary-59.13 {Tcl_BinaryObjCmd: scan} {
+ catch {unset arg1}
+ set arg1 1
+ list [catch {binary scan \x3f\xcc\xcc\xcd r1 arg1(a)} msg] $msg
+} {1 {can't set "arg1(a)": variable isn't array}}
+test binary-59.14 {Tcl_BinaryObjCmd: scan} {nonPortable macOrUnix} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a\x05 R2c* arg1 arg2] $arg1 $arg2
+} {2 {1.60000002384 3.40000009537} 5}
+test binary-59.15 {Tcl_BinaryObjCmd: scan} {nonPortable pcOnly} {
+ catch {unset arg1 arg2}
+ set arg1 foo
+ set arg2 bar
+ list [binary scan \xcd\xcc\xcc\x3f\x9a\x99\x59\x40\x05 r2c* arg1 arg2] $arg1 $arg2
+} {2 {1.60000002384 3.40000009537} 5}
+
# cleanup
::tcltest::cleanupTests
return
