Tcl Source Code

Check-in [42dcb6f5f3]
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.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:TIP #275: Support unsigned values in binary command
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 42dcb6f5f3007d09105779ce79e56b66c9da2a7d
User & Date: patthoyts 2006-10-06 13:37:20
Context
2006-10-06
14:14
bug #1571954: avoid /RTCc flag with MSVC8 check-in: 921a289f09 user: patthoyts tags: trunk, tip-278-branch-root
13:37
TIP #275: Support unsigned values in binary command check-in: 42dcb6f5f3 user: patthoyts tags: trunk
05:57
* library/http/http.tcl (http::geturl): only do geturl url rfc 3986 validity checking if $::http::...
check-in: 83351aed02 user: hobbs tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to ChangeLog.







1
2
3
4
5
6
7





2006-10-05  Andreas Kupries  <[email protected]>

	* library/tm.tcl: Fixed bug in TIP #189 implementation, now
	  allowing '_' in module names.

2006-10-05  Jeff Hobbs  <[email protected]>

>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
2006-10-06  Pat Thoyts  <[email protected]>

	* doc/binary.n:        TIP #275: Support unsigned values in
	* generic/tclBinary.c: binary command. Tests and documentation
	* tests/binary.test:   updated.

2006-10-05  Andreas Kupries  <[email protected]>

	* library/tm.tcl: Fixed bug in TIP #189 implementation, now
	  allowing '_' in module names.

2006-10-05  Jeff Hobbs  <[email protected]>

Changes to doc/binary.n.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
..
31
32
33
34
35
36
37
38

39
40
41
42
43
44
45
46

47
48
49
50
51
52
53
...
376
377
378
379
380
381
382

383
384
385
386
387
388
389
390
391
392
393
394
395


396
397
398
399
400
401
402
...
425
426
427
428
429
430
431
432
433
434
435

436
437
438
439
440
441
442
443
'\"
'\" 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.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.28 2005/12/16 11:12:31 dkf Exp $
'\" 
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings
................................................................................
.PP
The \fBbinary format\fR command generates a binary string whose layout
is specified by the \fIformatString\fR and whose contents come from
the additional arguments.  The resulting binary value is returned.
.PP
The \fIformatString\fR consists of a sequence of zero or more field
specifiers separated by zero or more spaces.  Each field specifier is
a single type character followed by an optional numeric \fIcount\fR.

Most field specifiers consume one argument to obtain the value to be
formatted.  The type character specifies how the value is to be
formatted.  The \fIcount\fR typically indicates how many items of the
specified type are taken from the value.  If present, the \fIcount\fR
is a non-negative decimal integer or \fB*\fR, which normally indicates
that all of the items in the value are to be used.  If the number of
arguments does not match the number of fields in the format string
that consume arguments, then an error is generated.

.PP
Here is a small example to clarify the relation between the field
specifiers and the arguments:
.CS
\fBbinary format\fR d3d {1.0 2.0 3.0 4.0} 0.1
.CE
.PP
................................................................................
Each \fIvarName\fR gives the name of a variable; when a field is
scanned from \fIstring\fR the result is assigned to the corresponding
variable.
.PP
As with \fBbinary format\fR, the \fIformatString\fR consists of a
sequence of zero or more field specifiers separated by zero or more
spaces.  Each field specifier is a single type character followed by

an optional numeric \fIcount\fR.  Most field specifiers consume one
argument to obtain the variable into which the scanned values should
be placed.  The type character specifies how the binary data is to be
interpreted.  The \fIcount\fR typically indicates how many items of
the specified type are taken from the data.  If present, the
\fIcount\fR is a non-negative decimal integer or \fB*\fR, which
normally indicates that all of the remaining items in the data are to
be used.  If there are not enough bytes left after the current cursor
position to satisfy the current field specifier, then the
corresponding variable is left untouched and \fBbinary scan\fR returns
immediately with the number of variables that were set.  If there are
not enough arguments for all of the fields in the format string that
consume arguments, then an error is generated.


.PP
A similar example as with \fBbinary format\fR should explain the
relation between field specifiers and arguments in case of the binary
scan subcommand:
.CS
\fBbinary scan\fR $bytes s3s first second
.CE
................................................................................
long data size values.  In doing this, values that have their high
bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints),
will be sign extended.  Thus the following will occur:
.CS
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
If you want to produce an unsigned value, then you can mask the return 
value to the desired size.  For example, to produce an unsigned short 
value:
.CS

set val [expr { $val & 0xFFFF }]; \fI# val == 0x8000\fR
.CE
.PP
Each type-count pair moves an imaginary cursor through the binary data,
reading bytes from the current position.  The cursor is initially
at position 0 at the beginning of the data.  The type may be any one of
the following characters:
.IP \fBa\fR 5





|







 







|
>







|
>







 







>
|











|
>
>







 







|
|
<

>
|







1
2
3
4
5
6
7
8
9
10
11
12
13
14
..
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
...
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
...
430
431
432
433
434
435
436
437
438

439
440
441
442
443
444
445
446
447
448
'\"
'\" 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.
'\" 
'\" RCS: @(#) $Id: binary.n,v 1.29 2006/10/06 13:37:20 patthoyts Exp $
'\" 
.so man.macros
.TH binary n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
binary \- Insert and extract fields from binary strings
................................................................................
.PP
The \fBbinary format\fR command generates a binary string whose layout
is specified by the \fIformatString\fR and whose contents come from
the additional arguments.  The resulting binary value is returned.
.PP
The \fIformatString\fR consists of a sequence of zero or more field
specifiers separated by zero or more spaces.  Each field specifier is
a single type character followed by an optional flag character followed
by an optional numeric \fIcount\fR.
Most field specifiers consume one argument to obtain the value to be
formatted.  The type character specifies how the value is to be
formatted.  The \fIcount\fR typically indicates how many items of the
specified type are taken from the value.  If present, the \fIcount\fR
is a non-negative decimal integer or \fB*\fR, which normally indicates
that all of the items in the value are to be used.  If the number of
arguments does not match the number of fields in the format string
that consume arguments, then an error is generated. The flag character
is ignored for for \fBbinary format\fR.
.PP
Here is a small example to clarify the relation between the field
specifiers and the arguments:
.CS
\fBbinary format\fR d3d {1.0 2.0 3.0 4.0} 0.1
.CE
.PP
................................................................................
Each \fIvarName\fR gives the name of a variable; when a field is
scanned from \fIstring\fR the result is assigned to the corresponding
variable.
.PP
As with \fBbinary format\fR, the \fIformatString\fR consists of a
sequence of zero or more field specifiers separated by zero or more
spaces.  Each field specifier is a single type character followed by
an optional flag character followed by an optional numeric \fIcount\fR.
Most field specifiers consume one
argument to obtain the variable into which the scanned values should
be placed.  The type character specifies how the binary data is to be
interpreted.  The \fIcount\fR typically indicates how many items of
the specified type are taken from the data.  If present, the
\fIcount\fR is a non-negative decimal integer or \fB*\fR, which
normally indicates that all of the remaining items in the data are to
be used.  If there are not enough bytes left after the current cursor
position to satisfy the current field specifier, then the
corresponding variable is left untouched and \fBbinary scan\fR returns
immediately with the number of variables that were set.  If there are
not enough arguments for all of the fields in the format string that
consume arguments, then an error is generated. The flag character 'u'
may be given to cause some types to be read as unsigned values. The flag
is accepted for all field types but is ignored for non-integer fields.
.PP
A similar example as with \fBbinary format\fR should explain the
relation between field specifiers and arguments in case of the binary
scan subcommand:
.CS
\fBbinary scan\fR $bytes s3s first second
.CE
................................................................................
long data size values.  In doing this, values that have their high
bit set (0x80 for chars, 0x8000 for shorts, 0x80000000 for ints),
will be sign extended.  Thus the following will occur:
.CS
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR
.CE
If you require unsigned values you can include the 'u' flag character following
the field type. For example, to read an unsigned short value:

.CS
set signShort [\fBbinary format\fR s1 0x8000]
\fBbinary scan\fR $signShort su1 val; \fI# val == 0x00008000\fR
.CE
.PP
Each type-count pair moves an imaginary cursor through the binary data,
reading bytes from the current position.  The cursor is initially
at position 0 at the beginning of the data.  The type may be any one of
the following characters:
.IP \fBa\fR 5

Changes to generic/tclBinary.c.

6
7
8
9
10
11
12
13
14
15
16

17
18
19
20
21
22
23
24
25
26
27







28
29
30
31
32
33
34
..
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
...
559
560
561
562
563
564
565

566
567
568
569
570
571
572
...
604
605
606
607
608
609
610

611
612
613
614
615
616
617
618
...
766
767
768
769
770
771
772

773
774
775
776
777
778
779
780
....
1024
1025
1026
1027
1028
1029
1030

1031
1032
1033
1034
1035
1036
1037
1038
....
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
....
1369
1370
1371
1372
1373
1374
1375
1376

1377
1378
1379
1380
1381
1382
1383
....
1393
1394
1395
1396
1397
1398
1399




1400
1401
1402
1403
1404
1405
1406
....
1774
1775
1776
1777
1778
1779
1780

1781
1782
1783
1784
1785
1786
1787
....
1790
1791
1792
1793
1794
1795
1796

1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808

1809
1810

1811
1812
1813
1814
1815
1816
1817
....
1820
1821
1822
1823
1824
1825
1826

1827
1828

1829
1830
1831
1832
1833
1834
1835
....
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853


1854
1855



1856
1857
1858

1859
1860
1861
1862
1863
1864
1865
....
1916
1917
1918
1919
1920
1921
1922








1923

1924
1925
1926
1927
1928
1929
1930
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.29 2006/08/10 12:15:30 dkf Exp $
 */

#include "tclInt.h"


#include <math.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. */








/*
 * 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.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practise when
 * overflow happens, and makes little odds the rest of the time (as measured
................................................................................

static void		DupByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    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);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(CONST void *from, void *to,
			    unsigned int length, int type);
................................................................................
{
    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. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
................................................................................

	format = Tcl_GetString(objv[2]);
	arg = 3;
	offset = 0;
	length = 0;
	while (*format != '\0') {
	    str = format;

	    if (!GetFormatSpec(&format, &cmd, &count)) {
		break;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A':
	    case 'b':
	    case 'B':
................................................................................
	 */

	arg = 3;
	format = Tcl_GetString(objv[2]);
	cursor = buffer;
	maxPos = cursor;
	while (*format != 0) {

	    if (!GetFormatSpec(&format, &cmd, &count)) {
		break;
	    }
	    if ((count == 0) && (cmd != '@')) {
		arg++;
		continue;
	    }
	    switch (cmd) {
................................................................................
	buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
	format = Tcl_GetString(objv[3]);
	cursor = buffer;
	arg = 4;
	offset = 0;
	while (*format != '\0') {
	    str = format;

	    if (!GetFormatSpec(&format, &cmd, &count)) {
		goto done;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A': {
		unsigned char *src;

................................................................................
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_NOCOUNT) {
		    if ((length - offset) < size) {
			goto done;
		    }
		    valuePtr = ScanNumber(buffer+offset, cmd, &numberCachePtr);
		    offset += size;
		} else {
		    if (count == BINARY_ALL) {
			count = (length - offset) / size;
		    }
		    if ((length - offset) < (count * size)) {
			goto done;
		    }
		    valuePtr = Tcl_NewObj();
		    src = buffer+offset;
		    for (i = 0; i < count; i++) {
			elementPtr = ScanNumber(src, cmd, &numberCachePtr);
			src += size;
			Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr);
		    }
		    offset += count*size;
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
................................................................................
 *----------------------------------------------------------------------
 */

static int
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.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
................................................................................

    /*
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
    (*formatPtr)++;




    if (**formatPtr == '*') {
	(*formatPtr)++;
	(*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
	(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
	(*countPtr) = BINARY_NOCOUNT;
................................................................................
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ScanNumber(
    unsigned char *buffer,	/* Buffer to scan number from. */
    int type,			/* Format character from "binary scan" */

    Tcl_HashTable **numberCachePtrPtr)
				/* Place to look for cache of scanned
				 * value objects, or NULL if too many
				 * different numbers have been scanned. */
{
    long value;
    float fvalue;
................................................................................

    /*
     * 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 (type) {
    case 'c':
	/*
	 * Characters need special handling. We want to produce a signed
	 * result, but on some platforms (such as AIX) chars are unsigned. To
	 * deal with this, check for a value that should be negative but
	 * isn't.
	 */

	value = buffer[0];

	if (value & 0x80) {
	    value |= -0x100;

	}
	goto returnNumericObject;

	/*
	 * 16-bit numeric values. We need the sign extension trick (see above)
	 * here as well.
	 */
................................................................................
    case 'S':
    case 't':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] + (buffer[1] << 8));
	} else {
	    value = (long) (buffer[1] + (buffer[0] << 8));
	}

	if (value & 0x8000) {
	    value |= -0x10000;

	}
	goto returnNumericObject;

	/*
	 * 32-bit numeric values.
	 */

................................................................................
    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(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));
	}

	/*
	 * 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:

	if (*numberCachePtrPtr == NULL) {
	    return Tcl_NewLongObj(value);
	} else {
................................................................................
		    | (((Tcl_WideUInt) buffer[5]) << 16)
		    | (((Tcl_WideUInt) buffer[4]) << 24)
		    | (((Tcl_WideUInt) buffer[3]) << 32)
		    | (((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 with the
	 * integer part of the cache.
	 */







|



>











>
>
>
>
>
>
>







 







|

|







 







>







 







>
|







 







>
|







 







>
|







 







|











|







 







|
>







 







>
>
>
>







 







>







 







>












>
|
|
>







 







>
|
|
>







 







|




|





>
>


>
>
>
|
|
|
>







 







>
>
>
>
>
>
>
>
|
>







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
..
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
...
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
...
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
...
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
....
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
....
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
....
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
....
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
....
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
....
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
....
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
....
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
....
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
 *
 * Copyright (c) 1997 by Sun Microsystems, Inc.
 * Copyright (c) 1998-1999 by Scriptics Corporation.
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 *
 * RCS: @(#) $Id: tclBinary.c,v 1.30 2006/10/06 13:37:21 patthoyts Exp $
 */

#include "tclInt.h"
#include "tclTomMath.h"

#include <math.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. */

/*
 * 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.)
 * Theoretically, it would be possible to keep the cache about for the values
 * that are already in it, but that makes the code slower in practise when
 * overflow happens, and makes little odds the rest of the time (as measured
................................................................................

static void		DupByteArrayInternalRep(Tcl_Obj *srcPtr,
			    Tcl_Obj *copyPtr);
static int		FormatNumber(Tcl_Interp *interp, int type,
			    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);
static void		DeleteScanNumberCache(Tcl_HashTable *numberCachePtr);
static int		NeedReversing(int format);
static void		CopyNumber(CONST void *from, void *to,
			    unsigned int length, int type);
................................................................................
{
    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. */
    int flags;			/* Format field flags */
    char *format;		/* Pointer to current position in format
				 * string. */
    Tcl_Obj *resultPtr = NULL;	/* Object holding result buffer. */
    unsigned char *buffer;	/* Start of result buffer. */
    unsigned char *cursor;	/* Current position within result buffer. */
    unsigned char *maxPos;	/* Greatest position within result buffer that
				 * cursor has visited.*/
................................................................................

	format = Tcl_GetString(objv[2]);
	arg = 3;
	offset = 0;
	length = 0;
	while (*format != '\0') {
	    str = format;
	    flags = 0;
	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
		break;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A':
	    case 'b':
	    case 'B':
................................................................................
	 */

	arg = 3;
	format = Tcl_GetString(objv[2]);
	cursor = buffer;
	maxPos = cursor;
	while (*format != 0) {
	    flags = 0;
	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
		break;
	    }
	    if ((count == 0) && (cmd != '@')) {
		arg++;
		continue;
	    }
	    switch (cmd) {
................................................................................
	buffer = Tcl_GetByteArrayFromObj(objv[2], &length);
	format = Tcl_GetString(objv[3]);
	cursor = buffer;
	arg = 4;
	offset = 0;
	while (*format != '\0') {
	    str = format;
	    flags = 0;
	    if (!GetFormatSpec(&format, &cmd, &count, &flags)) {
		goto done;
	    }
	    switch (cmd) {
	    case 'a':
	    case 'A': {
		unsigned char *src;

................................................................................
		    DeleteScanNumberCache(numberCachePtr);
		    goto badIndex;
		}
		if (count == BINARY_NOCOUNT) {
		    if ((length - offset) < size) {
			goto done;
		    }
		    valuePtr = ScanNumber(buffer+offset, cmd, flags, &numberCachePtr);
		    offset += size;
		} else {
		    if (count == BINARY_ALL) {
			count = (length - offset) / size;
		    }
		    if ((length - offset) < (count * size)) {
			goto done;
		    }
		    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);
		    }
		    offset += count*size;
		}

		resultPtr = Tcl_ObjSetVar2(interp, objv[arg], NULL, valuePtr,
................................................................................
 *----------------------------------------------------------------------
 */

static int
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.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
................................................................................

    /*
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
    (*formatPtr)++;
    if (**formatPtr == 'u') {
	(*formatPtr)++;
	(*flagsPtr) |= BINARY_UNSIGNED;
    }
    if (**formatPtr == '*') {
	(*formatPtr)++;
	(*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
	(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
	(*countPtr) = BINARY_NOCOUNT;
................................................................................
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
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
				 * different numbers have been scanned. */
{
    long value;
    float fvalue;
................................................................................

    /*
     * 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.
     * This practice is disabled if the BINARY_UNSIGNED flag is set.
     */

    switch (type) {
    case 'c':
	/*
	 * Characters need special handling. We want to produce a signed
	 * result, but on some platforms (such as AIX) chars are unsigned. To
	 * deal with this, check for a value that should be negative but
	 * isn't.
	 */

	value = buffer[0];
	if (!(flags & BINARY_UNSIGNED)) {
	    if (value & 0x80) {
		value |= -0x100;
	    }
	}
	goto returnNumericObject;

	/*
	 * 16-bit numeric values. We need the sign extension trick (see above)
	 * here as well.
	 */
................................................................................
    case 'S':
    case 't':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0] + (buffer[1] << 8));
	} else {
	    value = (long) (buffer[1] + (buffer[0] << 8));
	}
	if (!(flags & BINARY_UNSIGNED)) {
	    if (value & 0x8000) {
		value |= -0x10000;
	    }
	}
	goto returnNumericObject;

	/*
	 * 32-bit numeric values.
	 */

................................................................................
    case 'i':
    case 'I':
    case 'n':
	if (NeedReversing(type)) {
	    value = (long) (buffer[0]
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (((long)buffer[3]) << 24));
	} else {
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
		    + (buffer[1] << 16)
		    + (((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 ((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:

	if (*numberCachePtrPtr == NULL) {
	    return Tcl_NewLongObj(value);
	} else {
................................................................................
		    | (((Tcl_WideUInt) buffer[5]) << 16)
		    | (((Tcl_WideUInt) buffer[4]) << 24)
		    | (((Tcl_WideUInt) buffer[3]) << 32)
		    | (((Tcl_WideUInt) buffer[2]) << 40)
		    | (((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
	 * keys and the values stored are utterly incompatible with the
	 * integer part of the cache.
	 */

Changes to tests/binary.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
901
902
903
904
905
906
907
























908
909
910
911
912
913
914
...
941
942
943
944
945
946
947
















948
949
950
951
952
953
954
...
981
982
983
984
985
986
987








988
989
990
991
992
993
994
....
1021
1022
1023
1024
1025
1026
1027












1028
1029
1030
1031
1032
1033
1034
....
1061
1062
1063
1064
1065
1066
1067












1068
1069
1070
1071
1072
1073
1074
....
1380
1381
1382
1383
1384
1385
1386




















1387
1388
1389
1390
1391
1392
1393
....
1459
1460
1461
1462
1463
1464
1465




















1466
1467
1468
1469
1470
1471
1472
....
1796
1797
1798
1799
1800
1801
1802












1803
1804
1805
1806
1807
1808
1809
....
1837
1838
1839
1840
1841
1842
1843












1844
1845
1846
1847
1848
1849
1850
....
1878
1879
1880
1881
1882
1883
1884












1885
1886
1887
1888
1889
1890
1891
....
1919
1920
1921
1922
1923
1924
1925












1926
1927
1928
1929
1930
1931
1932
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.28 2006/04/05 15:17:39 dgp Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-26.10 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x70\x87\x05 c2c* arg1 arg2] $arg1 $arg2
} {2 {112 -121} 5}

























test binary-27.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc s} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-27.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-27.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 s2c* arg1 arg2] $arg1 $arg2
} {2 {-23726 21587} 5}

















test binary-28.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc S} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-28.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-28.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x52\xa3\x53\x54\x05 S2c* arg1 arg2] $arg1 $arg2
} {2 {21155 21332} 5}









test binary-29.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc i} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-29.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-29.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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-30.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc I} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-30.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-30.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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-31.1 {Tcl_BinaryObjCmd: scan} {
    list [catch {binary scan abc f} msg] $msg
} {1 {not enough arguments for all format specifiers}}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
................................................................................
    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 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: 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 I5 arg1] $arg1
} {1 {16843010 -2130640639 25297153 16876033 16843137}}





















test binary-40.3 {ScanNumber: NaN} \
    -body {
	catch {unset arg1}
	list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
    } \
    -match glob \
................................................................................
    binary scan [binary format w [expr {wide(3) << 31}]] w x
    set x
} 6442450944
test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
    binary scan [binary format W [expr {wide(3) << 31}]] W x
    set x
} 6442450944





















test binary-45.1 {Tcl_BinaryObjCmd: combined wide int handling} {
    binary scan [binary format sws 16450 -1 19521] c* x
    set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
    binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    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} bigEndian  {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    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} littleEndian {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian  {
    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} bigEndian  {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    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 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} bigEndian {
    catch {unset arg1}






|







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







 







>
>
>
>
>
>
>
>
>
>
>
>







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
...
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
...
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
....
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
....
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
....
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
....
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
....
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
....
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
....
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
....
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
....
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
#
# Copyright (c) 1997 by Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: binary.test,v 1.29 2006/10/06 13:37:21 patthoyts Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    package require tcltest
    namespace import -force ::tcltest::*
}
testConstraint bigEndian [expr {$tcl_platform(byteOrder) eq "bigEndian"}]
testConstraint littleEndian [expr {$tcl_platform(byteOrder) eq "littleEndian"}]
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-26.10 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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
} {1 {not enough arguments for all format specifiers}}
test binary-27.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54 s* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-27.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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
} {1 {not enough arguments for all format specifiers}}
test binary-28.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54 S* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-28.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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
} {1 {not enough arguments for all format specifiers}}
test binary-29.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 i* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-29.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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
} {1 {not enough arguments for all format specifiers}}
test binary-30.2 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1}
    list [binary scan \x52\xa3\x53\x54\x01\x02\x03\x04 I* arg1] $arg1
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-30.9 {Tcl_BinaryObjCmd: scan} {
    catch {unset arg1 arg2}
    set arg1 foo
    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
} {1 {not enough arguments for all format specifiers}}
test binary-31.2 {Tcl_BinaryObjCmd: scan} bigEndian {
    catch {unset arg1}
    list [binary scan \x3f\xcc\xcc\xcd\x40\x59\x99\x9a f* arg1] $arg1
................................................................................
    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 {33620225 16843137 16876033 25297153 -2130640639}}
test binary-39.5 {ScanNumber: 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 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 {
	catch {unset arg1}
	list [binary scan \xff\xff\xff\xff f1 arg1] $arg1
    } \
    -match glob \
................................................................................
    binary scan [binary format w [expr {wide(3) << 31}]] w x
    set x
} 6442450944
test binary-44.4 {Tcl_BinaryObjCmd: scan wide int with bit 31 set} {} {
    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
    set x
} {66 64 -1 -1 -1 -1 -1 -1 -1 -1 65 76}
test binary-45.2 {Tcl_BinaryObjCmd: combined wide int handling} {
    binary scan [binary format sWs 16450 0x7fffffff 19521] c* x
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-54.9 {Tcl_BinaryObjCmd: scan} littleEndian {
    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}
test binary-55.10 {Tcl_BinaryObjCmd: scan} littleEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x80\x00\x80 tut arg1 arg2] $arg1 $arg2
} {2 32768 -32768}
test binary-55.11 {Tcl_BinaryObjCmd: scan} littleEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x80\x00\x80 ttu arg1 arg2] $arg1 $arg2
} {2 -32768 32768}

# 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} bigEndian  {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-55.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    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}
test binary-55.10 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x80\x00 tut arg1 arg2] $arg1 $arg2
} {2 32768 -32768}
test binary-55.11 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x80\x00 ttu arg1 arg2] $arg1 $arg2
} {2 -32768 32768}

# 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} littleEndian {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-56.9 {Tcl_BinaryObjCmd: scan} littleEndian  {
    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}
test binary-57.10 {Tcl_BinaryObjCmd: scan} littleEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2
} {2 128 128}
test binary-57.11 {Tcl_BinaryObjCmd: scan} littleEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2
} {2 2147483648 -2147483648}

# 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} bigEndian  {
    catch {unset arg1}
................................................................................
} {1 {can't set "arg1(a)": variable isn't array}}
test binary-57.9 {Tcl_BinaryObjCmd: scan} bigEndian  {
    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}
test binary-57.10 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x80\x00\x00\x00\x80\x00\x00\x00 nun arg1 arg2] $arg1 $arg2
} {2 2147483648 -2147483648}
test binary-57.11 {Tcl_BinaryObjCmd: scan} bigEndian  {
    catch {unset arg1 arg2}
    set arg1 foo
    set arg2 bar
    list [binary scan \x00\x00\x00\x80\x00\x00\x00\x80 nun arg1 arg2] $arg1 $arg2
} {2 128 128}

# 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} bigEndian {
    catch {unset arg1}