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
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, *resultDictPtr, *returnOptsPtr, *chanObjPtr;
    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
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_SetObjResult(interp, Tcl_ObjPrintf(
		    "error reading \"%s\": %s",
		    TclGetString(chanObjPtr), Tcl_PosixError(interp)));
	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);
	}
	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;
	exitstatus = TCL_ERROR;
    }

    /*
     * If requested, remove the last newline in the channel if at EOF.
     */
    } else if ((charactersRead > 0) && (newline != 0)) {
	/*
	 * 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;
    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
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}}
	}
    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
	}
    # 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
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} cres copts]
    set status [catch {read $f} d copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status $cres
    lappend hd $status [dict get $copts -errorinfo]
} -cleanup {
    close $f
    removeFile io-75.6
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}
} -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 status [catch {read $f} d copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd [eof $f]
    lappend hd $status
    lappend hd $cres
    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} ¡}
} -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
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 {
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 status [catch {read $f} d 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]
    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
    lappend res $hd
    close $f
	return $res
    return $res
} -cleanup {
    removeFile io-75.10
} -match glob -result {41 {error reading "*": illegal byte sequence} c0}
} -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 status [catch {read $f} d copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status
    lappend hd $cres
    lappend hd [dict get $copts -errorinfo]
} -cleanup {
    close $f
    removeFile io-75.11
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}
} -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 status [catch {read $f} d copts]
    set d [dict get $copts -result read]
    close $f
    binary scan $d H* hd
	lappend res $hd $status $cres
	return $res
    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 {
} -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
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} cres copts]
    set status [catch {read $f} d copts]
    set d [dict get $copts -result read]
    binary scan $d H* hd
    lappend hd $status
    close $f
    lappend hd $cres
    lappend hd [dict get $copts -errorinfo]
} -cleanup {
    removeFile io-75.13
} -match glob -result {41 1 {error reading "*": illegal byte sequence}}
} -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
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
} -returnCodes error -cleanup {
	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
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} {
    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
    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}}
} -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
    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!}
} -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
    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 *bad code*}
} -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]; note $msg
    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 *bad code*}
} -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]; note $msg
    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 *bad code*}
} -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
    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\
} -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
    -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
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] $msg
    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!}
}} 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
    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 *bad code*}
}} 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] $msg
    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 *bad code*}
}} 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] $msg
    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 *bad code*}
}} 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 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
}} 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
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
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} {set ::total [list error $s]}
    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
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 {}
} -result {error {invalid block type}}
} -match glob -result {error {} invalid\\ block\\ type*}
test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
    proc bgerror {s} {set ::total [list error $s]}
    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
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 {}
} -result {error {invalid stored block lengths}}
} -match glob -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]}
    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
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 {}
} -result {error {incorrect header check}}
} -match glob -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]}
    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
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} {set ::total [list error $s]}
    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
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 {}
} -result {error {invalid block type}}
} -match glob -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 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