Changes On Branch 1a225bd50e984fdc
Not logged in

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

Changes In Branch py-b8f575aa23-errorinfo Through [1a225bd50e] Excluding Merge-Ins

This is equivalent to a diff from 080b9a1c81 to 1a225bd50e

2023-02-02
22:51
Fix for [b8f575aa2398b0e4] and [154ed7ce564a7b4c], double-[read]/[gets] problem. Partial-read funct... check-in: 11c7f071cb user: pooryorick tags: py-b8f575aa23-nopartial
2023-01-17
20:09
Fix for [b8f575aa2398b0e4], and also for [154ed7ce56], Tcl 9: [gets] on -strictencoding 1 configured... Closed-Leaf check-in: 4cdf4836aa user: pooryorick tags: py-b8f575aa23-errorinfo
15:34
Fix [read] error behaviour under issue [b8f575aa2398b0e4] by always returning returning successfully... check-in: 1a225bd50e user: pooryorick tags: py-b8f575aa23-errorinfo
2023-01-08
10:07
For [read] and [gets] encoding errors, use "-result read" in return options dictionary instead of j... Closed-Leaf check-in: 080b9a1c81 user: pooryorick tags: py-b8f575aa23
2023-01-02
23:12
Merge py-b8f575aa23: Fix for [154ed7ce56], Tcl 9: [gets] on -strictencoding 1 configured channel. check-in: 8c5d9bcc6e user: pooryorick tags: py-b8f575aa23

Changes to generic/tclIOCmd.c.
383
384
385
386
387
388
389

390
391
392
393
394
395
396
397
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int newline, i;		/* Discard newline at end? */
    int toRead;			/* How many bytes to read? */
    int charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */

    Tcl_Obj *resultPtr, *resultDictPtr, *returnOptsPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");







>
|







383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
    Tcl_Obj *const objv[])	/* Argument objects. */
{
    Tcl_Channel chan;		/* The channel to read from. */
    int newline, i;		/* Discard newline at end? */
    int toRead;			/* How many bytes to read? */
    int charactersRead;		/* How many characters were read? */
    int mode;			/* Mode in which channel is opened. */
    int exitstatus = TCL_OK;
    Tcl_Obj *resultPtr, *chanObjPtr;

    if ((objc != 2) && (objc != 3)) {
	Interp *iPtr;

    argerror:
	iPtr = (Interp *) interp;
	Tcl_WrongNumArgs(interp, 1, objv, "channelId ?numChars?");
467
468
469
470
471
472
473
474

475


476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (!TclChanCaughtErrorBypass(interp, chan)) {

	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(


		    "error reading \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	}
	resultDictPtr = Tcl_NewDictObj();
	Tcl_DictObjPut(NULL, resultDictPtr, Tcl_NewStringObj("read", -1)
	    , resultPtr);
	returnOptsPtr = Tcl_NewDictObj();
	Tcl_DictObjPut(NULL, returnOptsPtr, Tcl_NewStringObj("-result", -1)
	    , resultDictPtr);
	TclChannelRelease(chan);
	Tcl_DecrRefCount(resultPtr);
	Tcl_SetReturnOptions(interp, returnOptsPtr);
	return TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */

    if ((charactersRead > 0) && (newline != 0)) {
	const char *result;
	int length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    TclChannelRelease(chan);
    Tcl_DecrRefCount(resultPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekObjCmd --
 *







|
>
|
>
>
|
|

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

<











|







468
469
470
471
472
473
474
475
476
477
478
479
480
481
482









483

484
485
486
487
488

489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
	/*
	 * TIP #219.
	 * Capture error messages put by the driver into the bypass area and
	 * put them into the regular interpreter result. Fall back to the
	 * regular message if nothing was found in the bypass.
	 */

	if (TclChanCaughtErrorBypass(interp, chan)) {
	    Tcl_AddObjErrorInfo(interp, Tcl_GetString(Tcl_ObjPrintf(
		"\n %s", Tcl_GetString(Tcl_GetObjResult(interp)))),-1);
	} else {
	    Tcl_AddObjErrorInfo(interp, Tcl_GetString(Tcl_ObjPrintf(
		"error reading \"%s\": %s",
		TclGetString(chanObjPtr), Tcl_PosixError(interp))), -1);
	}









	exitstatus = TCL_ERROR;

    } else if ((charactersRead > 0) && (newline != 0)) {
	/*
	 * If requested, remove the last newline in the channel if at EOF.
	 */


	const char *result;
	int length;

	result = TclGetStringFromObj(resultPtr, &length);
	if (result[length - 1] == '\n') {
	    Tcl_SetObjLength(resultPtr, length - 1);
	}
    }
    Tcl_SetObjResult(interp, resultPtr);
    TclChannelRelease(chan);
    Tcl_DecrRefCount(resultPtr);
    return exitstatus;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SeekObjCmd --
 *
Changes to tests/io.test.
1546
1547
1548
1549
1550
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
1585
1586
1587
1588
1589
1590
    set in [read $f]
    close $f
    scan [string index $in end] %c
} 160


apply [list {} {
	set template {
		test io-12.9.@variant@ {ReadChars: multibyte chars split, default (strict)} -body {
			set res {}
			set f [open $path(test1) w]
			fconfigure $f -translation binary
			puts -nonewline $f [string repeat a 9]\xC2
			close $f
			set f [open $path(test1)]
			fconfigure $f -encoding utf-8 @strict@ -buffersize 10
			set status [catch {read $f} cres copts]
			set in [dict get $copts -result]
			lappend res $in
			lappend res $status $cres
			set status [catch {read $f} cres copts]
			set in [dict get $copts -result]
			lappend res $in
			lappend res $status $cres
			set res
		} -cleanup {
			catch {close $f}
		} -match glob -result {{read aaaaaaaaa} 1\
			{error reading "*": illegal byte sequence}\
			{read {}} 1 {error reading "*": illegal byte sequence}}
	}

	# strict encoding may be the default in Tcl 9, but in 8 it is not
	foreach variant {encodingstrict} strict {{-strictencoding 1}} {
		set script [string map [
			list @variant@ $variant @strict@ $strict] $template] 
		uplevel 1 $script
	}
} [namespace current]]


test io-12.10 {ReadChars: multibyte chars split} -body {
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    puts -nonewline $f [string repeat a 9]\xC2







|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|

|
|
|
|
|
|







1546
1547
1548
1549
1550
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
1585
1586
1587
1588
1589
1590
    set in [read $f]
    close $f
    scan [string index $in end] %c
} 160


apply [list {} {
    set template {
	test io-12.9.@variant@ {ReadChars: multibyte chars split, default (strict)} -body {
	    set res {}
	    set f [open $path(test1) w]
	    fconfigure $f -translation binary
	    puts -nonewline $f [string repeat a 9]\xC2
	    close $f
	    set f [open $path(test1)]
	    fconfigure $f -encoding utf-8 @strict@ -buffersize 10
	    set status [catch {read $f} cres copts]
	    set in [dict get $copts -errorinfo]
	    lappend res $status $cres
	    lappend res $in
	    set status [catch {read $f} cres copts]
	    set in [dict get $copts -errorinfo]
	    lappend res $status $cres
	    lappend res $in
	    set res
	} -cleanup {
	    catch {close $f}
	} -match glob -result {1 aaaaaaaaa\
	    {error reading "*"*:*illegal byte sequence*"read $f"}\
	    1 {} {error reading "*"*:*illegal byte sequence*"read $f"}}
    }

    # strict encoding may be the default in Tcl 9, but in 8 it is not
    foreach variant {encodingstrict} strict {{-strictencoding 1}} {
	set script [string map [
	    list @variant@ $variant @strict@ $strict] $template] 
	uplevel 1 $script
    }
} [namespace current]]


test io-12.10 {ReadChars: multibyte chars split} -body {
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    puts -nonewline $f [string repeat a 9]\xC2
9076
9077
9078
9079
9080
9081
9082
9083
9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101
9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
9120
9121
    fconfigure $f -encoding binary
    # \x81 is invalid in utf-8
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status $cres
} -cleanup {
    close $f
    removeFile io-75.6
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}

test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup {
    set fn [makeFile {} io-75.7]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later.
    puts -nonewline $f A\xA1\x1A
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd [eof $f]
    lappend hd $status
    lappend hd $cres
    fconfigure $f -encoding iso8859-1
    lappend hd [read $f];# We changed encoding, so now we can read the \xA1
    close $f
    set hd
} -cleanup {
    removeFile io-75.7
} -match glob -result {41 0 1 {error reading "*": illegal byte sequence} ¡}

test io-75.8.incomplete {
    incomplete uft-8 char after eof char is not an error (-strictencoding 1)
} -setup {
    set hd {}
    set fn [makeFile {} io-75.8]
    set f [open $fn w+]







|
<

|



|











|
<



|






|







9076
9077
9078
9079
9080
9081
9082
9083

9084
9085
9086
9087
9088
9089
9090
9091
9092
9093
9094
9095
9096
9097
9098
9099
9100
9101

9102
9103
9104
9105
9106
9107
9108
9109
9110
9111
9112
9113
9114
9115
9116
9117
9118
9119
    fconfigure $f -encoding binary
    # \x81 is invalid in utf-8
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} d copts]

    binary scan $d H* hd
    lappend hd $status [dict get $copts -errorinfo]
} -cleanup {
    close $f
    removeFile io-75.6
} -match glob -result {41 1 {error reading "*": illegal byte sequence*}}

test io-75.7 {invalid utf-8 encoding eof handling (-strictencoding 1)} -setup {
    set fn [makeFile {} io-75.7]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # \xA1 is invalid in utf-8. -eofchar is not detected, because it comes later.
    puts -nonewline $f A\xA1\x1A
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar \x1A -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} d copts]

    binary scan $d H* hd
    lappend hd [eof $f]
    lappend hd $status
    lappend hd [dict get $copts -errorinfo]
    fconfigure $f -encoding iso8859-1
    lappend hd [read $f];# We changed encoding, so now we can read the \xA1
    close $f
    set hd
} -cleanup {
    removeFile io-75.7
} -match glob -result {41 0 1 {error reading "*": illegal byte sequence*} ¡}

test io-75.8.incomplete {
    incomplete uft-8 char after eof char is not an error (-strictencoding 1)
} -setup {
    set hd {}
    set fn [makeFile {} io-75.8]
    set f [open $fn w+]
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209
9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237
9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258
9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
9274
9275
9276
9277
9278
    binary scan $d H* hd
    set hd
} -cleanup {
    removeFile io-75.10
} -result 41c0


test io-75.10_strict {incomplete multibyte encoding read is an error} -setup {
	set res {}
    set fn [makeFile {} io-75.10]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\xC0
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -strictencoding 1 -buffering none
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
	lappend res $hd $cres
	chan configure $f -encoding iso8859-1
	set d [read $f]
    binary scan $d H* hd
	lappend res $hd
    close $f
	return $res
} -cleanup {
    removeFile io-75.10
} -match glob -result {41 {error reading "*": illegal byte sequence} c0}


# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in raw bytes} -setup {
    set fn [makeFile {} io-75.11]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # In shiftjis, \x81 starts a two-byte sequence.
    # But 2nd byte \xFF is not allowed
    puts -nonewline $f A\x81\xFFA
    flush $f
    seek $f 0
    fconfigure $f -encoding shiftjis -buffering none -eofchar "" \
		-translation lf -strictencoding 1
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status
    lappend hd $cres
} -cleanup {
    close $f
    removeFile io-75.11
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}


test io-75.12 {invalid utf-8 encoding read is an error} -setup {
	set res {}
    set fn [makeFile {} io-75.12]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
		-strictencoding 1
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    close $f
    binary scan $d H* hd
	lappend res $hd $status $cres
	return $res
} -cleanup {
    removeFile io-75.12
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}
test io-75.12_ignore {invalid utf-8 encoding read is ignored} -setup {
    set fn [makeFile {} io-75.12]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar {} \







|









|
<

|
|
|

|

|


|
















|
<


|



|













|
<


|
|


|
|







9192
9193
9194
9195
9196
9197
9198
9199
9200
9201
9202
9203
9204
9205
9206
9207
9208
9209

9210
9211
9212
9213
9214
9215
9216
9217
9218
9219
9220
9221
9222
9223
9224
9225
9226
9227
9228
9229
9230
9231
9232
9233
9234
9235
9236
9237

9238
9239
9240
9241
9242
9243
9244
9245
9246
9247
9248
9249
9250
9251
9252
9253
9254
9255
9256
9257
9258

9259
9260
9261
9262
9263
9264
9265
9266
9267
9268
9269
9270
9271
9272
9273
    binary scan $d H* hd
    set hd
} -cleanup {
    removeFile io-75.10
} -result 41c0


test io-75.10.strict {incomplete multibyte encoding read is an error} -setup {
	set res {}
    set fn [makeFile {} io-75.10]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\xC0
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -strictencoding 1 -buffering none
} -body {
    set status [catch {read $f} d copts]

    binary scan $d H* hd
    lappend res $hd [dict get $copts -errorinfo] 
    chan configure $f -encoding iso8859-1
    set d [read $f]
    binary scan $d H* hd
    lappend res $hd
    close $f
    return $res
} -cleanup {
    removeFile io-75.10
} -match glob -result {41 {error reading "*": illegal byte sequence*} c0}


# As utf-8 has a special treatment in multi-byte decoding, also test another
# one.
test io-75.11 {shiftjis encoding error read results in raw bytes} -setup {
    set fn [makeFile {} io-75.11]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # In shiftjis, \x81 starts a two-byte sequence.
    # But 2nd byte \xFF is not allowed
    puts -nonewline $f A\x81\xFFA
    flush $f
    seek $f 0
    fconfigure $f -encoding shiftjis -buffering none -eofchar "" \
		-translation lf -strictencoding 1
} -body {
    set status [catch {read $f} d copts]

    binary scan $d H* hd
    lappend hd $status
    lappend hd [dict get $copts -errorinfo]
} -cleanup {
    close $f
    removeFile io-75.11
} -match glob -result {41 1 {error reading "*": illegal byte sequence*}}


test io-75.12 {invalid utf-8 encoding read is an error} -setup {
	set res {}
    set fn [makeFile {} io-75.12]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar {} -translation lf \
		-strictencoding 1
} -body {
    set status [catch {read $f} d copts]

    close $f
    binary scan $d H* hd
    lappend res $hd $status [dict get $copts -errorinfo]
    return $res
} -cleanup {
    removeFile io-75.12
} -match glob -result {41 1 {error reading "*": illegal byte sequence*}}
test io-75.12.ignore {invalid utf-8 encoding read is ignored} -setup {
    set fn [makeFile {} io-75.12]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    puts -nonewline $f A\x81
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar {} \
9291
9292
9293
9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
9308
9309
9310
9311
9312
9313
    fconfigure $f -encoding binary
    # \x81 is invalid in utf-8
    puts -nonewline $f "A\x81"
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} cres copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status
    close $f
    lappend hd $cres
} -cleanup {
    removeFile io-75.13
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}

test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after error} -setup {
    set res {} 
    set fn [makeFile {} io-75.14]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # \xc0 is invalid in utf-8







|
<



|


|







9286
9287
9288
9289
9290
9291
9292
9293

9294
9295
9296
9297
9298
9299
9300
9301
9302
9303
9304
9305
9306
9307
    fconfigure $f -encoding binary
    # \x81 is invalid in utf-8
    puts -nonewline $f "A\x81"
    flush $f
    seek $f 0
    fconfigure $f -encoding utf-8 -buffering none -eofchar "" -translation lf -strictencoding 1
} -body {
    set status [catch {read $f} d copts]

    binary scan $d H* hd
    lappend hd $status
    close $f
    lappend hd [dict get $copts -errorinfo]
} -cleanup {
    removeFile io-75.13
} -match glob -result {41 1 {error reading "*": illegal byte sequence*}}

test io-75.14 {invalid utf-8 encoding [gets] coninues in non-strict mode after error} -setup {
    set res {} 
    set fn [makeFile {} io-75.14]
    set f [open $fn w+]
    fconfigure $f -encoding binary
    # \xc0 is invalid in utf-8
Changes to tests/ioCmd.test.
860
861
862
863
864
865
866

867


868
869
870
871
872
873
874
875
	} finalize {} watch {} read {
	    catch {close $chan}
	    return a
	}
    }
    set ch [chan create read foo]
} -body {

    read $ch 1


} -returnCodes error -cleanup {
    catch {close $ch}
    rename foo {}
} -match glob -result {*invalid argument*}
test iocmd-21.23 {[close] in [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}







>
|
>
>
|







860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
	} finalize {} watch {} read {
	    catch {close $chan}
	    return a
	}
    }
    set ch [chan create read foo]
} -body {
    set status [catch {
	read $ch 1
    } cres copts]
    list $status [dict get $copts -errorinfo]
} -cleanup {
    catch {close $ch}
    rename foo {}
} -match glob -result {*invalid argument*}
test iocmd-21.23 {[close] in [gets] segfaults} -setup {
    proc foo {method chan args} {
	switch -- $method initialize {
	    return {initialize finalize watch read}
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066


1067
1068
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
1095
1096
1097
1098
1099
1100
1101


1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113


1114
1115
1116
1117
1118
1119
1120
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
1147
1148
    note [read $c 10]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return [string repeat snarf 1000]
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg]; note $msg


    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {read delivered more than requested}}
test iocmd-23.3 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track; note MUST_NOT_HAPPEN
    }
    set c [chan create {w} foo]
    note [catch {read $c 2} msg]; note $msg
    close $c
    rename foo {}
    set res
} -result {1 {channel "rc*" wasn't opened for reading}}
test iocmd-23.4 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg]; note $msg


    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 BOOM!}
test iocmd-23.5 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg]; note $msg


    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.6 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg]; note $msg


    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.7 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg]; note $msg


    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 *bad code*}
test iocmd-23.8 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt


    close $c
    rename foo {}
    set res

} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iocmd-23.9 {chan read, no data means eof} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return ""
    }
    set c [chan create {r w} foo]







|




|
>
>



|


















|
>
>



|







|
>
>



|







|
>
>



|







|
>
>



|







|
>
>



>
|







1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
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
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
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
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
    note [read $c 10]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
test iocmd-23.2 {chan read, bad data return, to much} -match glob -body {
    set res {}
    proc foo args {
	oninit; onfinal; track
	return [string repeat snarf 1000]
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg copts]
    note $msg
    note [dict get $copts -errorinfo]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {read delivered more than requested*}}
test iocmd-23.3 {chan read, for non-readable channel} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track; note MUST_NOT_HAPPEN
    }
    set c [chan create {w} foo]
    note [catch {read $c 2} msg]; note $msg
    close $c
    rename foo {}
    set res
} -result {1 {channel "rc*" wasn't opened for reading}}
test iocmd-23.4 {chan read, error return} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code error BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg copts]
    note $msg
    note [dict get $copts -errorinfo]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {BOOM!*}}
test iocmd-23.5 {chan read, break return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code break BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg copts]
    note $msg
    note [dict get $copts -errorinfo]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {chan handler *bad code*}}
test iocmd-23.6 {chan read, continue return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code continue BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg copts]
    note $msg
    note [dict get $copts -errorinfo]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {chan handler *bad code*}}
test iocmd-23.7 {chan read, custom return is error} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg copts]
    note $msg
    note [dict get $copts -errorinfo]
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {chan handler *bad code*}}
test iocmd-23.8 {chan read, level is squashed} -match glob -body {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return -level 55 -code 777 BOOM!
    }
    set c [chan create {r w} foo]
    note [catch {read $c 2} msg opt]
    note $msg
    noteOpts $opt
    close $c
    rename foo {}
    set res
} -result {{read rc* 4096} 1 {} {-code 1 -level 0 -errorcode NONE\
    -errorline 1 -errorinfo *bad code*subcommand "read"*}}
test iocmd-23.9 {chan read, no data means eof} -match glob -setup {
    set res {}
    proc foo {args} {
	oninit; onfinal; track
	return ""
    }
    set c [chan create {r w} foo]
Changes to tests/ioTrans.test.
446
447
448
449
450
451
452
453

454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469

470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501

502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523

524
525
526
527
528
529
530
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code error BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg] $msg

} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 BOOM!}
test iortrans-4.4 {chan read, break return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code break BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg] $msg

} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.5 {chan read, continue return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code continue BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg] $msg

} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.6 {chan read, custom return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg] $msg

} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 *bad code*}
test iortrans-4.7 {chan read, level is squashed} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -level 55 -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg opt] $msg
    noteOpts $opt
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}

test iortrans-4.8 {chan read, read, bug 2921116} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args







|
>




|










|
>




|










|
>




|










|
>




|
















|
>







446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code error BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg copts] $msg
    lappend res [dict get $copts -errorinfo]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 {} {BOOM!*}}
test iortrans-4.4 {chan read, break return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code break BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg copts] $msg
    lappend res [dict get $copts -errorinfo]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 {} {chan handler returned bad code*}}
test iortrans-4.5 {chan read, continue return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code continue BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg copts] $msg
    lappend res [dict get $copts -errorinfo]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 {} {chan handler returned bad code*}}
test iortrans-4.6 {chan read, custom return is error} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg copts] $msg
    lappend res [dict get $copts -errorinfo]
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 {} {chan handler returned bad code*}}
test iortrans-4.7 {chan read, level is squashed} -setup {
    set res {}
} -match glob -body {
    proc foo {args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
	return -level 55 -code 777 BOOM!
    }
    set c [chan push [tempchan] foo]
    lappend res [catch {read $c 2} msg opt] $msg
    noteOpts $opt
} -cleanup {
    tempdone
    rename foo {}
} -result {{read rt* {test data
}} 1 {} {-code 1 -level 0 -errorcode NONE -errorline 1\
    -errorinfo *bad code*subcommand "read"*}}
test iortrans-4.8 {chan read, read, bug 2921116} -setup {
    set res {}
} -match glob -body {
    proc foo {fd args} {
	handle.initialize
	handle.finalize
	lappend ::res $args
Changes to tests/zlib.test.
19
20
21
22
23
24
25

26
27
28
29
30
31
32
testConstraint recentZlib 0
catch {
    # Work around a bug in some versions of zlib; known to manifest on at
    # least Mac OS X Mountain Lion...
    testConstraint recentZlib \
	    [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6]
}


test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}







>







19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
testConstraint recentZlib 0
catch {
    # Work around a bug in some versions of zlib; known to manifest on at
    # least Mac OS X Mountain Lion...
    testConstraint recentZlib \
	    [package vsatisfies [zlib::pkgconfig get zlibVersion] 1.2.6]
}
interp bgerror {} [list [namespace current]::bgerror]

test zlib-1.1 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib
} -result {wrong # args: should be "zlib command arg ?...?"}
test zlib-1.2 {zlib basics} -constraints zlib -returnCodes error -body {
    zlib ? {}
} -result {bad command "?": must be adler32, compress, crc32, decompress, deflate, gunzip, gzip, inflate, push, or stream}
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
    close $s
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
} -result {eof 500}
test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
    proc bgerror {s} {set ::total [list error $s]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push gzip $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {







|







698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
    close $s
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
} -result {eof 500}
test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
    proc bgerror {s o} {set ::total [list error $s [dict get $o -errorinfo]]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push gzip $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -result {error {invalid block type}}
test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
    proc bgerror {s} {set ::total [list error $s]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push compress $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {







|

|







729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -match glob -result {error {} invalid\\ block\\ type*}
test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
    proc bgerror {s o} {set ::total [list error $s [dict get $o -errorinfo]]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push compress $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -result {error {invalid stored block lengths}}
test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
    proc bgerror {s} {set ::total [list error $s]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push deflate $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {







|

|







762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -match glob -result {error {} invalid\\ stored\\ block\\ lengths*}
test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
    proc bgerror {s o} {set ::total [list error $s [dict get $o -errorinfo]]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary -buffering none -blocking 0
        zlib push deflate $c
        puts -nonewline $c [string repeat hello 100]
        close $c
    }}} 0]
} -body {
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -result {error {incorrect header check}}

test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
    zlib
} -setup {
    proc bgerror {s} {set ::total [list error $s]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary
        zlib push inflate $c
        chan event $c readable [list apply {{c} {
            set d [read $c]
            if {[eof $c]} {
                chan event $c readable {}







|




|







795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
        close $s
    }
    set ::total
} -cleanup {
    unset -nocomplain total
    close $srv
    rename bgerror {}
} -match glob -result {error {} incorrect\\ header\\ check*}

test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
    zlib
} -setup {
    proc bgerror {s o} {set ::total [list error $s]}
    set srv [socket -myaddr localhost -server {apply {{c a p} {
        chan configure $c -translation binary
        zlib push inflate $c
        chan event $c readable [list apply {{c} {
            set d [read $c]
            if {[eof $c]} {
                chan event $c readable {}
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
    close $srv
    rename bgerror {}
} -returnCodes error \
  -result {bad event name "xyzzy": must be readable or writable}
test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
    zlib
} -setup {
    proc bgerror {s} {set ::total [list error $s]}
    proc zlibRead {c} {
        set d [read $c]
        if {[eof $c]} {
            chan event $c readable {}
            close $c
            set ::total [list eof [string length $d]]
        }







|







841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
    close $srv
    rename bgerror {}
} -returnCodes error \
  -result {bad event name "xyzzy": must be readable or writable}
test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
    zlib
} -setup {
    proc bgerror {s o} {set ::total [list error $s [dict get $o -errorinfo]]}
    proc zlibRead {c} {
        set d [read $c]
        if {[eof $c]} {
            chan event $c readable {}
            close $c
            set ::total [list eof [string length $d]]
        }
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
    after cancel {set ::total timeout}
    after cancel {set ::total done}
    set ::total
} -cleanup {
    close $srv
    rename bgerror {}
    rename zlibRead {}
} -result {error {invalid block type}}
test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
    zlib
} -setup {
    proc bgerror {s} {set ::total [list error $s]}
    proc zlibRead {c} {
        if {[gets $c line] < 0} {
            close $c
            set ::total [list error -1]
        } elseif {[eof $c]} {
            chan event $c readable {}
            close $c







|



|







875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
    after cancel {set ::total timeout}
    after cancel {set ::total done}
    set ::total
} -cleanup {
    close $srv
    rename bgerror {}
    rename zlibRead {}
} -match glob -result {error {} {invalid block type*}}
test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
    zlib
} -setup {
    proc bgerror {s o} {set ::total [list error $s]}
    proc zlibRead {c} {
        if {[gets $c line] < 0} {
            close $c
            set ::total [list error -1]
        } elseif {[eof $c]} {
            chan event $c readable {}
            close $c