Tcl Source Code

Check-in [48caefe5a1]
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:merge 8.7
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: 48caefe5a1568a29596fc0565d58d4429f0e27e6a153d0406f4dec809628ec7b
User & Date: sebres 2018-07-26 19:10:41
Context
2018-07-31
20:36
merge 8.7 check-in: bd1ba8d1b5 user: jan.nijtmans tags: trunk
2018-07-30
19:00
merge trunk check-in: 6e3719d0e0 user: jan.nijtmans tags: memory-API
2018-07-26
19:10
merge 8.7 check-in: 48caefe5a1 user: sebres tags: trunk
18:58
merge 8.6: bug [d051b77fc1] fixed check-in: 4e57a1242b user: sebres tags: core-8-branch
2018-07-21
18:46
Merge 8.7: Add a note in the 'clock' man page about the interpretation of impossible values on [cloc... check-in: 4b94075b58 user: kbk tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/tclStringObj.c.

1844
1845
1846
1847
1848
1849
1850





1851
1852
1853
1854
1855
1856
1857
....
2997
2998
2999
3000
3001
3002
3003

3004
3005
3006
3007
3008
3009

3010



3011

3012

3013
3014
3015
3016
3017
3018
3019
....
3157
3158
3159
3160
3161
3162
3163
3164







3165
3166
3167
3168
3169
3170
3171
	/*
	 * Step 3. Minimum field width.
	 */

	width = 0;
	if (isdigit(UCHAR(ch))) {
	    width = strtoul(format, &end, 10);





	    format = end;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
................................................................................
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it
	 */


	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;

	    if (objPtr->bytes == NULL) {

		int numBytes;





		Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */

		if (numBytes) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    } else if (numBytes > INT_MAX - length) {
			goto overflow;
		    }
................................................................................
	} else {
	    objResultPtr = Tcl_NewByteArrayObj(NULL, length);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;

	    if (objPtr->bytes == NULL) {







		int more;
		unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
		memcpy(dst, src, (size_t) more);
		dst += more;
	    }
	}
    } else if (allowUniChar && requestUniChar) {






>
>
>
>
>







 







>





<
>
|
>
>
>

>

>







 







<
>
>
>
>
>
>
>







1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
....
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014

3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
....
3168
3169
3170
3171
3172
3173
3174

3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
	/*
	 * Step 3. Minimum field width.
	 */

	width = 0;
	if (isdigit(UCHAR(ch))) {
	    width = strtoul(format, &end, 10);
	    if (width < 0) {
		msg = overflow;
		errCode = "OVERFLOW";
		goto errorMsg;
	    }
	    format = end;
	    step = TclUtfToUniChar(format, &ch);
	} else if (ch == '*') {
	    if (objIndex >= objc - 1) {
		msg = badIndex[gotXpg];
		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
		goto errorMsg;
................................................................................
    } while (--oc && (binary || allowUniChar));

    if (binary) {
	/*
	 * Result will be pure byte array. Pre-size it
	 */

	int numBytes;
	ov = objv;
	oc = objc;
	do {
	    Tcl_Obj *objPtr = *ov++;


	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to count bytes for the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */

		if (numBytes) {
		    last = objc - oc;
		    if (length == 0) {
			first = last;
		    } else if (numBytes > INT_MAX - length) {
			goto overflow;
		    }
................................................................................
	} else {
	    objResultPtr = Tcl_NewByteArrayObj(NULL, length);
	    dst = Tcl_SetByteArrayLength(objResultPtr, length);
	}
	while (objc--) {
	    Tcl_Obj *objPtr = *objv++;


	    /*
	     * Every argument is either a bytearray with a ("pure")
	     * value we know we can safely use, or it is an empty string.
	     * We don't need to copy bytes from the empty strings.
	     */

	    if (TclIsPureByteArray(objPtr)) {
		int more;
		unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
		memcpy(dst, src, (size_t) more);
		dst += more;
	    }
	}
    } else if (allowUniChar && requestUniChar) {

Changes to tests/format.test.

592
593
594
595
596
597
598














599
600
601
602
603
604
605
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
    format %llx 0
} 0
test format-19.3 {Bug 2830354} {
    string length [format %340f 0]
} 340















# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
    set x [dict create a b c d]
    format %s $x
    # After this, obj in $x should be a dict
    # We are testing to make sure it has not been shimmered to a






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







592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
} -match regexp -result {-2414724693 f*701239ab}
test format-19.2 {Bug 1867855} {
    format %llx 0
} 0
test format-19.3 {Bug 2830354} {
    string length [format %340f 0]
} 340

test format-19.4.1 {Bug d498578df4: width overflow should cause limit exceeded} \
-constraints {longIs32bit} -body {
    # in case of overflow into negative, it produces width -2 (and limit exceeded),
    # in case of width will be unsigned, it will be outside limit (2GB for 32bit)...
    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
    format %[expr {0xffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"

test format-19.4.2 {Bug d498578df4: width overflow should cause limit exceeded} -body {
    # limit should exceeds in any case,
    # and it don't throw an error in case the bug is not fixed (and probably no segfault).
    format %[expr {0xffffffffffffffff - 1}]g 0
} -returnCodes error -result "max size for a Tcl value exceeded"

# Note that this test may fail in future versions
test format-20.1 {Bug 2932421: plain %s caused intrep change of args} -body {
    set x [dict create a b c d]
    format %s $x
    # After this, obj in $x should be a dict
    # We are testing to make sure it has not been shimmered to a

Changes to tests/string.test.

2302
2303
2304
2305
2306
2307
2308






2309
2310
2311
2312
2313
2314
2315
    set f [encoding convertto utf-8 {}]
} -cleanup {
    unset e f
} -body {
    tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
} -match glob -result {*no string representation}
}







}

# cleanup
rename MemStress {}
rename makeByteArray {}
rename makeUnicode {}






>
>
>
>
>
>







2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
    set f [encoding convertto utf-8 {}]
} -cleanup {
    unset e f
} -body {
    tcl::unsupported::representation [run {string cat $e $f $e $f [list x]}]
} -match glob -result {*no string representation}
}
test string-30.1.1.$noComp {[Bug ba921a8d98]: string cat} {
    run {string cat [set data [binary format a* hello]] [encoding convertto $data] [unset data]}
} hellohello
test string-30.1.2.$noComp {[Bug ba921a8d98]: inplace cat by subst (compiled to "strcat" instruction)} {
    run {set x "[set data [binary format a* hello]][encoding convertto $data][unset data]"}
} hellohello

}

# cleanup
rename MemStress {}
rename makeByteArray {}
rename makeUnicode {}