Tcl Source Code

Check-in [795b52feb7]
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:Make creating variables work correctly.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tip-450
Files: files | file ages | folders
SHA3-256: 795b52feb77a3ddff7d42676977bdd96fbfac509be4cb0ee139fa56bb2d3bc20
User & Date: dkf 2019-06-15 07:46:39
Context
2019-06-15
11:13
remove temporary page feed check-in: 241db3a03a user: dkf tags: tip-450
07:46
Make creating variables work correctly. check-in: 795b52feb7 user: dkf tags: tip-450
07:03
Rewrote to do modifications in-place unless Tcl_Obj is shared. check-in: 5c1e5aa513 user: dkf tags: tip-450
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclBinary.c.

1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417




1418
1419
1420
1421
1422
1423

1424
1425
1426



1427
1428
1429

1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450


1451

1452
1453
1454
1455
1456
1457
1458
....
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
....
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
....
1687
1688
1689
1690
1691
1692
1693


1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
....
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
....
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
....
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
....
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
....
1930
1931
1932
1933
1934
1935
1936








1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948

1949
1950
1951
1952
1953
1954
1955
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
BinarySetCmd(
    ClientData dummy,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    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 */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Var *varPtr, *arrayPtr;
    Tcl_Obj *valuePtr;		/* Object holding binary value 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.*/
    const char *errorString;
    const char *errorValue, *str;

    const unsigned char *bytes;
    int offset, size, length, originalLength, duplicated = 0;
    int type, isFloat, i, argLength, listc;



    ClientData data;
    Tcl_WideInt wide;
    Tcl_Obj **listv;


    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName formatString ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Trickery to create the variable if it didn't already exist but without
     * changing its internal representation at all; depends on the fact that
     * concatenating the empty string is a special case.
     */

    varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
	    "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }
    valuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, 0, -1);
    if (valuePtr == NULL) {
	TclNewObj(valuePtr);
    }


    (void) Tcl_GetByteArrayFromObj(valuePtr, &originalLength);

    length = originalLength;

    /*
     * To avoid copying the data, we format the string in two passes. The
     * first pass computes the size of the output buffer and checks that the
     * supplied values are legal. The second pass places the formatted data
     * into the buffer.
................................................................................
	     * of elements in the list stored in a single argument. If no
	     * count is specified, then the argument is taken as a single
	     * non-list value.
	     */

	    if (count == BINARY_NOCOUNT) {
		if (isFloat) {
		    double dummy;
		    if (TclGetNumberFromObj(NULL, objv[arg],
			    &data, &type) != TCL_OK) {
			return Tcl_GetDoubleFromObj(interp, objv[arg], &dummy);
		    }
		} else {
		    if (Tcl_GetWideIntFromObj(interp, objv[arg],
			    &wide) != TCL_OK) {
................................................................................
		} else if (count > listc) {
		    errorString =
			    "number of elements in list does not match count";
		    goto error;
		}
		for (i = 0; i < count; i++) {
		    if (isFloat) {
			double dummy;
			if (TclGetNumberFromObj(NULL, listv[i],
				&data, &type) != TCL_OK) {
			    return Tcl_GetDoubleFromObj(interp, listv[i],
				    &dummy);
			}
		    } else {
			if (Tcl_GetWideIntFromObj(interp, listv[i],
................................................................................
    /*
     * Prepare the result object by preallocating the caclulated number of
     * bytes and filling with nulls. Note that if we use an operation that can
     * fail part way through, we must duplicate here even if the object is
     * unshared because we mustn't mutate anything on failure. Bother.
     */



    if (Tcl_IsShared(valuePtr)) {
	valuePtr = Tcl_DuplicateObj(valuePtr);
	duplicated = 1;
    }
    buffer = Tcl_SetByteArrayLength(valuePtr, length);
    if (length > originalLength) {
	memset(buffer + originalLength, 0, length - originalLength);
    }

    /*
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 7) / 8);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "binary";
	    if (cmd == 'B') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 1;
		    if (str[offset] == '1') {
			value |= 1;
		    }
		    if (((offset + 1) % 8) == 0) {
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 1) / 2);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "hexadecimal";
	    if (cmd == 'H') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 4;
		    c = str[offset] - '0';
		    if (c > 9) {
			c += ('0' - 'A') + 10;
		    }
................................................................................
	case 'w':
	case 'W':
	case 'r':
	case 'R':
	case 'd':
	case 'q':
	case 'Q':
	case 'f': {

	    if (count == BINARY_NOCOUNT) {
		/*
		 * Note that we are casting away the const-ness of objv, but
		 * this is safe since we aren't going to modify the array.
		 */

		listv = (Tcl_Obj **) (objv + arg);
................................................................................
		/*
		 * Already checked the error cases.
		 */

		(void) FormatNumber(interp, cmd, listv[i], &cursor);
	    }
	    break;
	}
	case 'x':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    memset(cursor, 0, count);
	    cursor += count;
	    break;
................................................................................
		cursor = maxPos;
	    } else {
		cursor = buffer + count;
	    }
	    break;
	}
    }








    if (!TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, valuePtr,
	    TCL_LEAVE_ERR_MSG, -1)) {
	/*
	 * Failure here with an in-place modification means there are traces
	 * applying shenanigans.
	 */

	if (duplicated) {
	    TclDecrRefCount(valuePtr);
	}
	return TCL_ERROR;
    }

    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "expected %s string but got \"%s\" instead",
	    errorString, errorValue));






|













<
|
>
>
>
>






>
|
<
|
>
>
>
|
|
<
>






<
<
<
<
<
<
|
<
<
<
<
<

<
<
>
>
|
>







 







<







 







<







 







>
>
|

<







 







<







 







<







 







|
<







 







<







 







>
>
>
>
>
>
>
>
|
<





<
|
<


>







1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415

1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428

1429
1430
1431
1432
1433
1434

1435
1436
1437
1438
1439
1440
1441






1442





1443


1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
....
1585
1586
1587
1588
1589
1590
1591

1592
1593
1594
1595
1596
1597
1598
....
1615
1616
1617
1618
1619
1620
1621

1622
1623
1624
1625
1626
1627
1628
....
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691

1692
1693
1694
1695
1696
1697
1698
....
1749
1750
1751
1752
1753
1754
1755

1756
1757
1758
1759
1760
1761
1762
....
1802
1803
1804
1805
1806
1807
1808

1809
1810
1811
1812
1813
1814
1815
....
1864
1865
1866
1867
1868
1869
1870
1871

1872
1873
1874
1875
1876
1877
1878
....
1889
1890
1891
1892
1893
1894
1895

1896
1897
1898
1899
1900
1901
1902
....
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936

1937
1938
1939
1940
1941

1942

1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
BinarySetCmd(
    ClientData ignored,		/* Not used. */
    Tcl_Interp *interp,		/* Current interpreter. */
    int objc,			/* Number of arguments. */
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    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 */
    const char *format;		/* Pointer to current position in format
				 * string. */

    Tcl_Obj *valuePtr;		/* Object holding binary value buffer, which
				 * might be value read from variable, or might
				 * be duplicate or new. */
    int originalLength;		/* Length of the starting value read from the
				 * variable. */
    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.*/
    const char *errorString;
    const char *errorValue, *str;
    int offset, size, length, i, argLength;
    const unsigned char *bytes;	/* Working buffer for testing arguments. */

    Tcl_Obj **listv;		/* Used for parsing list arguments. */
    int listc;			/* Used for parsing list arguments. */
    int isFloat;		/* What type of number parsing to use. */
    int type;			/* Used for parsing numbers. */
    ClientData data;		/* Used for parsing numbers. */
    Tcl_WideInt wide;		/* Used for parsing numbers. */

    double dummy;		/* Used for parsing numbers. */

    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName formatString ?arg ...?");
	return TCL_ERROR;
    }







    valuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0);





    if (valuePtr == NULL) {


	originalLength = 0;
    } else {
	(void) Tcl_GetByteArrayFromObj(valuePtr, &originalLength);
    }
    length = originalLength;

    /*
     * To avoid copying the data, we format the string in two passes. The
     * first pass computes the size of the output buffer and checks that the
     * supplied values are legal. The second pass places the formatted data
     * into the buffer.
................................................................................
	     * of elements in the list stored in a single argument. If no
	     * count is specified, then the argument is taken as a single
	     * non-list value.
	     */

	    if (count == BINARY_NOCOUNT) {
		if (isFloat) {

		    if (TclGetNumberFromObj(NULL, objv[arg],
			    &data, &type) != TCL_OK) {
			return Tcl_GetDoubleFromObj(interp, objv[arg], &dummy);
		    }
		} else {
		    if (Tcl_GetWideIntFromObj(interp, objv[arg],
			    &wide) != TCL_OK) {
................................................................................
		} else if (count > listc) {
		    errorString =
			    "number of elements in list does not match count";
		    goto error;
		}
		for (i = 0; i < count; i++) {
		    if (isFloat) {

			if (TclGetNumberFromObj(NULL, listv[i],
				&data, &type) != TCL_OK) {
			    return Tcl_GetDoubleFromObj(interp, listv[i],
				    &dummy);
			}
		    } else {
			if (Tcl_GetWideIntFromObj(interp, listv[i],
................................................................................
    /*
     * Prepare the result object by preallocating the caclulated number of
     * bytes and filling with nulls. Note that if we use an operation that can
     * fail part way through, we must duplicate here even if the object is
     * unshared because we mustn't mutate anything on failure. Bother.
     */

    if (valuePtr == NULL) {
	valuePtr = Tcl_NewObj();
    } else if (Tcl_IsShared(valuePtr)) {
	valuePtr = Tcl_DuplicateObj(valuePtr);

    }
    buffer = Tcl_SetByteArrayLength(valuePtr, length);
    if (length > originalLength) {
	memset(buffer + originalLength, 0, length - originalLength);
    }

    /*
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 7) / 8);
	    if (count > length) {
		count = length;
	    }
	    value = 0;

	    if (cmd == 'B') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 1;
		    if (str[offset] == '1') {
			value |= 1;
		    }
		    if (((offset + 1) % 8) == 0) {
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 1) / 2);
	    if (count > length) {
		count = length;
	    }
	    value = 0;

	    if (cmd == 'H') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 4;
		    c = str[offset] - '0';
		    if (c > 9) {
			c += ('0' - 'A') + 10;
		    }
................................................................................
	case 'w':
	case 'W':
	case 'r':
	case 'R':
	case 'd':
	case 'q':
	case 'Q':
	case 'f':

	    if (count == BINARY_NOCOUNT) {
		/*
		 * Note that we are casting away the const-ness of objv, but
		 * this is safe since we aren't going to modify the array.
		 */

		listv = (Tcl_Obj **) (objv + arg);
................................................................................
		/*
		 * Already checked the error cases.
		 */

		(void) FormatNumber(interp, cmd, listv[i], &cursor);
	    }
	    break;

	case 'x':
	    if (count == BINARY_NOCOUNT) {
		count = 1;
	    }
	    memset(cursor, 0, count);
	    cursor += count;
	    break;
................................................................................
		cursor = maxPos;
	    } else {
		cursor = buffer + count;
	    }
	    break;
	}
    }

    /*
     * Store the value back in the variable. This is vital if the value was
     * allocated in this function, which could be the case if either we
     * duplicated a shared value or we are assigning the variable anew.
     */

    Tcl_IncrRefCount(valuePtr);
    if (!Tcl_ObjSetVar2(interp, objv[1], NULL, valuePtr, TCL_LEAVE_ERR_MSG)) {

	/*
	 * Failure here with an in-place modification means there are traces
	 * applying shenanigans.
	 */


	TclDecrRefCount(valuePtr);

	return TCL_ERROR;
    }
    TclDecrRefCount(valuePtr);
    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "expected %s string but got \"%s\" instead",
	    errorString, errorValue));

Changes to tests/binary.test.

2951
2952
2953
2954
2955
2956
2957
2958
2959








2960
2961
2962
2963
2964
2965
2966
} -result {1 {expected integer but got "gorp"} foobar}
test binary-79.7 {binary set: errors prevent creation} -setup {
    unset -nocomplain nosuchvar
} -body {
    list [catch {binary set nosuchvar ci 70 gorp} msg] $msg \
	[info exist nosuchvar]
} -cleanup {
    unset -nocomplain x
} -result {1 {expected integer but got "gorp"} 0}









test binary-80.1 {binary set: a} {
    set x abc
    binary set x a A
    binary encode hex $x
} 416263
test binary-80.2 {binary set: a} {






|

>
>
>
>
>
>
>
>







2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
} -result {1 {expected integer but got "gorp"} foobar}
test binary-79.7 {binary set: errors prevent creation} -setup {
    unset -nocomplain nosuchvar
} -body {
    list [catch {binary set nosuchvar ci 70 gorp} msg] $msg \
	[info exist nosuchvar]
} -cleanup {
    unset -nocomplain nosuchvar
} -result {1 {expected integer but got "gorp"} 0}
test binary-79.8 {binary set: create variable} -setup {
    unset -nocomplain nosuchvar
} -body {
    binary set nosuchvar "c3" {65 66 67}
    return $nosuchvar
} -cleanup {
    unset -nocomplain nosuchvar
} -result ABC

test binary-80.1 {binary set: a} {
    set x abc
    binary set x a A
    binary encode hex $x
} 416263
test binary-80.2 {binary set: a} {