Diff
Not logged in

Differences From Artifact [e4baf853cd]:

To Artifact [e9af3a006a]:


1180
1181
1182
1183
1184
1185
1186
1187

1188
1189
1190
1191
1192
1193
1194
1180
1181
1182
1183
1184
1185
1186

1187
1188
1189
1190
1191
1192
1193
1194







-
+







    # (bufPtr->nextAdded < bufPtr->bufLength)

    set f [open $path(test1) w]
    fconfigure $f -encoding binary
    puts -nonewline $f "1234567890\n123\x82\x4F\x82\x50\x82"
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding shiftjis
    fconfigure $f -encoding shiftjis -profile tcl8
    set x [list [gets $f line] $line [eof $f]]
    close $f
    set x
} [list 10 "1234567890" 0]
test io-7.3 {FilterInputBytes: split up character at EOF} {testchannel} {
    set f [open $path(test1) w]
    fconfigure $f -encoding binary
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
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
1591
1592
1593
1594
1595
1596
1597























1598
1599
1600
1601
1602

1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617

1618
1619
1620
1621
1622
1623
1624
1625

1626
1627
1628
1629
















1630

1631
1632
1633
1634
1635
1636

1637
1638
1639
1640
1641
1642
1643
1535
1536
1537
1538
1539
1540
1541























1542
1543
1544
1545
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
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601

1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616

1617
1618
1619
1620
1621
1622
1623
1624

1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645

1646
1647
1648
1649
1650
1651

1652
1653
1654
1655
1656
1657
1658
1659







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+




-
+





-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+




-
+














-
+







-
+




+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+





-
+







    vwait [namespace which -variable x]
    vwait [namespace which -variable x]
    lappend x [catch {close $f} msg] $msg
    set x
} "{} timeout {} timeout 牦 {} eof 0 {}"
test io-12.6 {ReadChars: too many chars read} {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        [string repeat 뻯 20][string repeat . 20]]
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [encoding convertto utf-8 \
			[string repeat 뻯 20][string repeat . 20]]
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan)
		return
	    }
	    watch {}
	    read {
		set n [lindex $args 1]
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8
    while {![eof $c]} {
        read $c 15
	read $c 15
    }
    close $c
} {}
test io-12.7 {ReadChars: too many chars read [bc5b790099]} {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        [string repeat 뻯 10]....뻯]
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [encoding convertto utf-8 \
			[string repeat 뻯 10]....뻯]
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan)
		return
	    }
	    watch {}
	    read {
		set n [lindex $args 1]
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8
    while {![eof $c]} {
        read $c 7
	read $c 7
    }
    close $c
} {}
test io-12.8 {ReadChars: multibyte chars split} {
    set f [open $path(test1) w]
    fconfigure $f -translation binary
    puts -nonewline $f [string repeat a 9]\xC2\xA0
    close $f
    set f [open $path(test1)]
    fconfigure $f -encoding utf-8 -buffersize 10
    set in [read $f]
    close $f
    scan [string index $in end] %c
} 160
test io-12.9 {ReadChars: multibyte chars split} -body {
test {io-12.9 profile tcl8} {ReadChars: multibyte chars split} -body {
    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 -profile tcl8 -buffersize 10
    set in [read $f]
    close $f
    read $f
    scan [string index $in end] %c
} -cleanup {
    catch {close $f}
} -result 194
test {io-12.10 strict} {ReadChars: multibyte chars split} -body {
    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 -profile strict -buffersize 10
    set in [read $f]
    close $f
    scan [string index $in end] %c
} -cleanup {
    catch {close $f}
} -returnCodes 1 -match glob -result {error reading "file*":\
	invalid or incomplete multibyte or wide character}


test io-12.10 {ReadChars: multibyte chars split} -body {
test {io-12.10 tcl8} {ReadChars: multibyte chars split} -body {
    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 -profile tcl8 -buffersize 11
    fconfigure $f -encoding utf-8 -profile tcl8 -buffersize 10
    set in [read $f]
    close $f
    scan [string index $in end] %c
} -cleanup {
    catch {close $f}
} -result 194

1986
1987
1988
1989
1990
1991
1992
1993

1994
1995
1996
1997
1998
1999
2000
2002
2003
2004
2005
2006
2007
2008

2009
2010
2011
2012
2013
2014
2015
2016







-
+







    set c
} hello
test io-14.9 {reuse of stdio special channels} {stdio fileevent} {
    file delete $path(script)
    file delete $path(test1)
    set f [open $path(script) w]
    puts $f {
        array set path [lindex $argv 0]
	array set path [lindex $argv 0]
	set f [open $path(test1) w]
	puts $f hello
	close $f
	close stderr
	set f [open "|[list [info nameofexecutable] $path(cat) $path(test1)]" r]
	puts [gets $f]
    }
2333
2334
2335
2336
2337
2338
2339
2340

2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354

2355
2356

2357
2358
2359
2360
2361
2362
2363
2349
2350
2351
2352
2353
2354
2355

2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369

2370
2371

2372
2373
2374
2375
2376
2377
2378
2379







-
+













-
+

-
+







	    puts -nonewline $f [read stdin 1024]
	}
	close $f
    }
    close $f
    set x 01234567890123456789012345678901
    for {set i 0} {$i < 11} {incr i} {
        set x "$x$x"
	set x "$x$x"
    }
    set f [open $path(output) w]
    close $f
    set f [open "|[list [interpreter] $path(pipe)]" w]
    fconfigure $f -blocking off
    puts -nonewline $f $x
    close $f
    set counter 0
    while {([file size $path(output)] < 65536) && ($counter < 1000)} {
	after 20 [list incr [namespace which -variable counter]]
	vwait [namespace which -variable counter]
    }
    if {$counter == 1000} {
        set result "file size only [file size $path(output)]"
	set result "file size only [file size $path(output)]"
    } else {
        set result ok
	set result ok
    }
} ok

# Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.

test io-28.1 {CloseChannel called when all references are dropped} {testchannel} {
    file delete $path(test1)
2423
2424
2425
2426
2427
2428
2429
2430

2431
2432

2433
2434
2435
2436
2437
2438
2439
2439
2440
2441
2442
2443
2444
2445

2446
2447

2448
2449
2450
2451
2452
2453
2454
2455







-
+

-
+







    close $f
    set counter 0
    while {([file size $path(output)] < 20480) && ($counter < 1000)} {
	after 20 [list incr [namespace which -variable counter]]
	vwait [namespace which -variable counter]
    }
    if {$counter == 1000} {
        set result probably_broken
	set result probably_broken
    } else {
        set result ok
	set result ok
    }
} ok
test io-28.4 Tcl_Close testchannel {
    file delete $path(test1)
    set l {}
    lappend l [lsort [testchannel open]]
    set f [open $path(test1) w]
4647
4648
4649
4650
4651
4652
4653
4654
4655
4656
4657
4658
4659
4660
4661
4662
4663
4664
4665
4666
4667
4668
4669
















4670
4671
4672
4673
4674
4675
4676






4677
4678
4679
4680
4681
4682
4683
4684
4685
4686
4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
4704
4705
4706
4707
4708
4709
4710
4711
























4712
4713
4714
4715
4716
4717
4718
4663
4664
4665
4666
4667
4668
4669
















4670
4671
4672
4673
4674
4675
4676
4677
4678
4679
4680
4681
4682
4683
4684
4685
4686






4687
4688
4689
4690
4691
4692
4693
4694
4695
4696
4697
4698
4699
4700
4701
4702
4703
























4704
4705
4706
4707
4708
4709
4710
4711
4712
4713
4714
4715
4716
4717
4718
4719
4720
4721
4722
4723
4724
4725
4726
4727
4728
4729
4730
4731
4732
4733
4734







-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
-
-
-
-
-
+
+
+
+
+
+











-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







    list [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
    close $c
    rename driver {}
} -result {{} {} {} .......}
test io-33.12 {Tcl_GetsObj, [10dc6daa37]} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) .......
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) .......
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan)
		return
	    }
	    watch {}
	    read {
		set n [lindex $args 1]
		if {$n > 3} {set n 3}
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
} -body {
    set c [chan create read [namespace which driver]]
    chan configure $c -blocking 0
    list [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
    close $c
    rename driver {}
} -result {{} {} {} .......}
test io-33.13 {Tcl_GetsObj, [10dc6daa37]} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [string repeat \
                        [string repeat . 64]\n[string repeat . 25] 2]
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
                if {$n > 65} {set n 65}
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [string repeat \
			[string repeat . 64]\n[string repeat . 25] 2]
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan)
		return
	    }
	    watch {}
	    read {
		set n [lindex $args 1]
		if {$n > 65} {set n 65}
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
} -body {
    set c [chan create read [namespace which driver]]
    chan configure $c -blocking 0
    list [gets $c] [gets $c] [gets $c] [gets $c] [gets $c]
} -cleanup {
    close $c
5425
5426
5427
5428
5429
5430
5431
5432
5433


5434
5435
5436
5437
5438
5439
5440
5441
5442
5443
5444
5445
5446
5447


5448
5449
5450
5451
5452
5453
5454
5455
5456







-
-
+
+







    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.4 {Tcl_InputBlocked vs files, event driven read} {fileevent} {
    proc in {f} {
        variable l
        variable x
	variable l
	variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
5461
5462
5463
5464
5465
5466
5467
5468
5469


5470
5471
5472
5473
5474
5475
5476
5477
5478
5479
5480
5481
5482
5483


5484
5485
5486
5487
5488
5489
5490
5491
5492







-
-
+
+







    lappend l [fblocked $f]
    lappend l [eof $f]
    close $f
    set l
} {0 abc 0 defghijklmnop 0 1}
test io-36.6 {Tcl_InputBlocked vs files, event driven read} {nonBlockFiles fileevent} {
    proc in {f} {
        variable l
        variable x
	variable l
	variable x
	lappend l [read $f 3]
	if {[eof $f]} {lappend l eof; close $f; set x done}
    }
    file delete $path(test1)
    set f [open $path(test1) w]
    puts $f abcdefghijklmnop
    close $f
5859
5860
5861
5862
5863
5864
5865
5866

5867
5868
5869
5870
5871
5872
5873
5875
5876
5877
5878
5879
5880
5881

5882
5883
5884
5885
5886
5887
5888
5889







-
+







    set l [list]
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{} auto}
test io-39.24 {Tcl_SetChannelOption, server socket is not readable or
        writable so we can't change -eofchar or -translation } {
    writable so we can't change -eofchar or -translation } {
    set l [list]
    set sock [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
    fconfigure $sock -eofchar D -translation lf
    lappend l [fconfigure $sock -eofchar] [fconfigure $sock -translation]
    close $sock
    set l
} {{} auto}
6357
6358
6359
6360
6361
6362
6363
6364
6365
6366
6367




6368
6369
6370
6371
6372
6373
6374
6375
6376
6377
6378
6379
6380








6381
6382
6383
6384
6385
6386
6387
6388
6389
6390
6391
6392
6393
6394
6395
6396
6397

6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412
6413

6414
6415
6416
6417

6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433
6434
6435

6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450
6451
6452
6453
6454
6455


6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469

6470
6471
6472
6473
6474
6475
6476
6373
6374
6375
6376
6377
6378
6379




6380
6381
6382
6383
6384
6385
6386
6387
6388








6389
6390
6391
6392
6393
6394
6395
6396
6397
6398
6399
6400
6401
6402
6403
6404
6405
6406
6407
6408
6409
6410
6411
6412

6413
6414
6415
6416
6417
6418
6419
6420
6421
6422
6423
6424
6425
6426
6427
6428

6429
6430
6431
6432

6433
6434
6435
6436
6437
6438
6439
6440
6441
6442
6443
6444
6445
6446
6447
6448
6449
6450

6451
6452
6453
6454
6455
6456
6457
6458
6459
6460
6461
6462
6463
6464
6465
6466
6467
6468
6469


6470
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483
6484

6485
6486
6487
6488
6489
6490
6491
6492







-
-
-
-
+
+
+
+





-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
















-
+















-
+



-
+

















-
+


















-
-
+
+













-
+







    after cancel $timer
    testfevent cmd {close $f}
    list [testfevent cmd {set x}] [testfevent cmd {info commands after}]
} {{f triggered: foo bar} after}
test io-46.2 {Tcl event loop vs multiple interpreters} testfevent {
    testfevent create
    testfevent cmd {
        variable x 0
        after 100 {set x triggered}
        vwait [namespace which -variable x]
        set x
	variable x 0
	after 100 {set x triggered}
	vwait [namespace which -variable x]
	set x
    }
} {triggered}
test io-46.3 {Tcl event loop vs multiple interpreters} testfevent {
    testfevent create
    testfevent cmd {
        set x 0
        after 10 {lappend x timer}
        after 30
        set result $x
        update idletasks
        lappend result $x
        update
        lappend result $x
	set x 0
	after 10 {lappend x timer}
	after 30
	set result $x
	update idletasks
	lappend result $x
	update
	lappend result $x
    }
} {0 0 {0 timer}}

test io-47.1 {fileevent vs multiple interpreters} {testfevent fileevent} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent cmd "fileevent $f2 readable {script 2}"
    fileevent $f3 readable {sript 3}
    set x {}
    lappend x [fileevent $f2 readable]
    testfevent delete
    lappend x [fileevent $f readable] [fileevent $f2 readable] \
        [fileevent $f3 readable]
	[fileevent $f3 readable]
    close $f
    close $f2
    close $f3
    set x
} {{} {script 1} {} {sript 3}}
test io-47.2 {deleting fileevent on interpreter delete} {testfevent fileevent} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    set f4 [open $path(foo) r]
    fileevent $f readable {script 1}
    testfevent create
    testfevent share $f2
    testfevent share $f3
    testfevent cmd "fileevent $f2 readable {script 2}
        fileevent $f3 readable {script 3}"
	fileevent $f3 readable {script 3}"
    fileevent $f4 readable {script 4}
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
		[fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {} {} {script 4}}
test io-47.3 {deleting fileevent on interpreter delete} {testfevent fileevent} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    set f3 [open $path(foo) r]
    set f4 [open $path(foo) r]
    testfevent create
    testfevent share $f3
    testfevent share $f4
    fileevent $f readable {script 1}
    fileevent $f2 readable {script 2}
    testfevent cmd "fileevent $f3 readable {script 3}
      fileevent $f4 readable {script 4}"
	fileevent $f4 readable {script 4}"
    testfevent delete
    set x [list [fileevent $f readable] [fileevent $f2 readable] \
                [fileevent $f3 readable] [fileevent $f4 readable]]
    close $f
    close $f2
    close $f3
    close $f4
    set x
} {{script 1} {script 2} {} {}}
test io-47.4 {file events on shared files and multiple interpreters} {testfevent fileevent} {
    set f  [open $path(foo) r]
    set f2 [open $path(foo) r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    fileevent $f2 readable {script 3}
    set x [list [fileevent $f2 readable] \
                [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
		[testfevent cmd "fileevent $f readable"] \
		[fileevent $f readable]]
    testfevent delete
    close $f
    close $f2
    set x
} {{script 3} {script 1} {script 2}}
test io-47.5 {file events on shared files, deleting file events} {testfevent fileevent} {
    set f [open $path(foo) r]
    testfevent create
    testfevent share $f
    testfevent cmd "fileevent $f readable {script 1}"
    fileevent $f readable {script 2}
    testfevent cmd "fileevent $f readable {}"
    set x [list [testfevent cmd "fileevent $f readable"] \
                [fileevent $f readable]]
		[fileevent $f readable]]
    testfevent delete
    close $f
    set x
} {{} {script 2}}
test io-47.6 {file events on shared files, deleting file events} {testfevent fileevent} {
    set f [open $path(foo) r]
    testfevent create
7318
7319
7320
7321
7322
7323
7324
7325

7326
7327
7328
7329
7330
7331
7332
7334
7335
7336
7337
7338
7339
7340

7341
7342
7343
7344
7345
7346
7347
7348







-
+







    set s0 [fcopy $f1 $f2]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.4 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
7359
7360
7361
7362
7363
7364
7365
7366

7367
7368
7369
7370
7371
7372
7373
7374
7375
7376
7377
7378
7379
7380
7381
7382
7383

7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398
7399
7400

7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415
7416
7417

7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434

7435
7436
7437
7438
7439
7440
7441
7375
7376
7377
7378
7379
7380
7381

7382
7383
7384
7385
7386
7387
7388
7389
7390
7391
7392
7393
7394
7395
7396
7397
7398

7399
7400
7401
7402
7403
7404
7405
7406
7407
7408
7409
7410
7411
7412
7413
7414
7415

7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432

7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449

7450
7451
7452
7453
7454
7455
7456
7457







-
+
















-
+
















-
+
















-
+
















-
+







    fcopy $f1 $f2 -size -1 ;# -1 means 'copy all', same as if no -size specified.
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {"$s1" == "$s2"} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.5a {TclCopyChannel, all, other negative value} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
    fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
    fcopy $f1 $f2 -size -2 ;# < 0 behaves like -1, copy all
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {"$s1" == "$s2"} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.5b {TclCopyChannel, all, wrap to negative value} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
    fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
    fcopy $f1 $f2 -size 3221176172 ;# Wrapped to < 0, behaves like -1, copy all
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {"$s1" == "$s2"} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.6 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
    fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
    set s0 [fcopy $f1 $f2 -size [expr {[file size $thisScript] + 5}]]
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    close $f1
    close $f2
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    if {("$s1" == "$s2") && ($s0 == $s1)} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.7 {TclCopyChannel} {fcopy} {
    file delete $path(test1)
    set f1 [open $thisScript]
    set f2 [open $path(test1) w]
    fconfigure $f1 -translation lf -encoding iso8859-1 -blocking 0
    fconfigure $f2 -translation lf -encoding iso8859-1 -blocking 0
    fcopy $f1 $f2
    set result [list [fconfigure $f1 -blocking] [fconfigure $f2 -blocking]]
    set s1 [file size $thisScript]
    set s2 [file size $path(test1)]
    close $f1
    close $f2
    if {"$s1" == "$s2"} {
        lappend result ok
	lappend result ok
    }
    set result
} {0 0 ok}
test io-52.8 {TclCopyChannel} {stdio fcopy} {
    file delete $path(test1)
    file delete $path(pipe)
    set f1 [open $path(pipe) w]
7983
7984
7985
7986
7987
7988
7989
7990
7991


7992
7993
7994
7995
7996
7997
7998
7999
8000
8001
8002
8003
8004
8005
8006

8007
8008

8009
8010
8011
8012
8013
8014
8015
7999
8000
8001
8002
8003
8004
8005


8006
8007
8008
8009
8010
8011
8012
8013
8014
8015
8016
8017
8018
8019
8020
8021

8022
8023

8024
8025
8026
8027
8028
8029
8030
8031







-
-
+
+














-
+

-
+







    variable fcopyTestCount
    incr fcopyTestCount $bytes
    if {[string length $error]} {
	set fcopyTestDone 1
    } elseif {[eof $in]} {
	set fcopyTestDone 0
    } else {
        # Delay next fcopy to wait for size>0 input bytes
        after 100 [list fcopy $in $out -size 1000 \
	# Delay next fcopy to wait for size>0 input bytes
	after 100 [list fcopy $in $out -size 1000 \
		-command [namespace code [list doFcopy $in $out]]]
    }
}
test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio fcopy} {
    variable fcopyTestDone
    file delete $path(pipe)
    catch {unset fcopyTestDone}
    set fcopyTestCount 0
    set f1 [open $path(pipe) w]
    puts $f1 {
	# Write  10 bytes / 10 msec
	proc Write {count} {
	    puts -nonewline "1234567890"
	    if {[incr count -1]} {
	        after 10 [list Write $count]
		after 10 [list Write $count]
	    } else {
	        set ::ready 1
		set ::ready 1
	    }
	}
	fconfigure stdout -buffering none
	Write 345 ;# 3450 bytes ~3.45 sec
	vwait ready
	exit 0
    }
8343
8344
8345
8346
8347
8348
8349
8350
8351
8352
8353
8354
8355
8356
8357
8358
8359
8360
8361












8362
8363
8364


8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
8378
8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394















8395
8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425
8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438





























8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469
8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482





























8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513
8514
8515
8516
8517
8518
8519
8520























8521
8522
8523
8524
8525
8526
8527
8359
8360
8361
8362
8363
8364
8365












8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
8378


8379
8380
8381
8382
8383
8384
8385
8386
8387
8388
8389
8390
8391
8392
8393
8394
8395















8396
8397
8398
8399
8400
8401
8402
8403
8404
8405
8406
8407
8408
8409
8410
8411
8412
8413
8414
8415
8416
8417
8418
8419
8420
8421
8422
8423
8424
8425





























8426
8427
8428
8429
8430
8431
8432
8433
8434
8435
8436
8437
8438
8439
8440
8441
8442
8443
8444
8445
8446
8447
8448
8449
8450
8451
8452
8453
8454
8455
8456
8457
8458
8459
8460
8461
8462
8463
8464
8465
8466
8467
8468
8469





























8470
8471
8472
8473
8474
8475
8476
8477
8478
8479
8480
8481
8482
8483
8484
8485
8486
8487
8488
8489
8490
8491
8492
8493
8494
8495
8496
8497
8498
8499
8500
8501
8502
8503
8504
8505
8506
8507
8508
8509
8510
8511
8512
8513























8514
8515
8516
8517
8518
8519
8520
8521
8522
8523
8524
8525
8526
8527
8528
8529
8530
8531
8532
8533
8534
8535
8536
8537
8538
8539
8540
8541
8542
8543







-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+

-
-
+
+















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+















-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







	    close $f1
	}
    }
    lindex $ch
} A
test io-53.13 {TclCopyChannel: read error reporting} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                return {initialize finalize watch read}
            }
            finalize {
                return
            }
            watch {}
            read {
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		return {initialize finalize watch read}
	    }
	    finalize {
		return
	    }
	    watch {}
	    read {
		error FAIL
            }
        }
	    }
	}
    }
    set outFile [makeFile {} out]
} -body {
    set in [chan create read [namespace which driver]]
    chan configure $in -translation binary
    set out [open $outFile wb]
    chan copy $in $out
} -cleanup {
    catch {close $in}
    catch {close $out}
    removeFile out
    rename driver {}
} -result {error reading "rc*": *} -returnCodes error -match glob
test io-53.14 {TclCopyChannel: write error reporting} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                return {initialize finalize watch write}
            }
            finalize {
                return
            }
            watch {}
            write {
                error FAIL
            }
        }
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		return {initialize finalize watch write}
	    }
	    finalize {
		return
	    }
	    watch {}
	    write {
		error FAIL
	    }
	}
    }
    set inFile [makeFile {aaa} in]
} -body {
    set in [open $inFile rb]
    set out [chan create write [namespace which driver]]
    chan configure $out -translation binary
    chan copy $in $out
} -cleanup {
    catch {close $in}
    catch {close $out}
    removeFile in
    rename driver {}
} -result {error writing "*": *} -returnCodes error -match glob
test io-53.15 {[ed29c4da21] DoRead: fblocked seen as error} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        variable blocked
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        [string repeat a 100]]
                set blocked($chan) 1
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan) blocked($chan)
                return
            }
            watch {}
            read {
                if {$blocked($chan)} {
                    set blocked($chan) [expr {!$blocked($chan)}]
                    return -code error EAGAIN
                }
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	variable blocked
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [encoding convertto utf-8 \
			[string repeat a 100]]
		set blocked($chan) 1
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan) blocked($chan)
		return
	    }
	    watch {}
	    read {
		if {$blocked($chan)} {
		    set blocked($chan) [expr {!$blocked($chan)}]
		    return -code error EAGAIN
		}
		set n [lindex $args 1]
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8
    set out [makeFile {} out]
    set outChan [open $out w]
    chan configure $outChan -encoding utf-8
} -body {
    chan copy $c $outChan
} -cleanup {
    close $outChan
    close $c
    removeFile out
} -result 100
test io-53.16 {[ed29c4da21] MBRead: fblocked seen as error} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        variable blocked
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        [string repeat a 100]]
                set blocked($chan) 1
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan) blocked($chan)
                return
            }
            watch {}
            read {
                if {$blocked($chan)} {
                    set blocked($chan) [expr {!$blocked($chan)}]
                    return -code error EAGAIN
                }
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	variable blocked
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [encoding convertto utf-8 \
			[string repeat a 100]]
		set blocked($chan) 1
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan) blocked($chan)
		return
	    }
	    watch {}
	    read {
		if {$blocked($chan)} {
		    set blocked($chan) [expr {!$blocked($chan)}]
		    return -code error EAGAIN
		}
		set n [lindex $args 1]
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8 -translation lf
    set out [makeFile {} out]
    set outChan [open $out w]
    chan configure $outChan -encoding utf-8 -translation lf
} -body {
    chan copy $c $outChan
} -cleanup {
    close $outChan
    close $c
    removeFile out
} -result 100
test io-53.17 {[7c187a3773] MBWrite: proper inQueueTail handling} -setup {
    proc driver {cmd args} {
        variable buffer
        variable index
        set chan [lindex $args 0]
        switch -- $cmd {
            initialize {
                set index($chan) 0
                set buffer($chan) [encoding convertto utf-8 \
                        line\n[string repeat a 100]line\n]
                return {initialize finalize watch read}
            }
            finalize {
                unset index($chan) buffer($chan)
                return
            }
            watch {}
            read {
                set n [lindex $args 1]
                set new [expr {$index($chan) + $n}]
                set result [string range $buffer($chan) $index($chan) $new-1]
                set index($chan) $new
                return $result
            }
        }
	variable buffer
	variable index
	set chan [lindex $args 0]
	switch -- $cmd {
	    initialize {
		set index($chan) 0
		set buffer($chan) [encoding convertto utf-8 \
			line\n[string repeat a 100]line\n]
		return {initialize finalize watch read}
	    }
	    finalize {
		unset index($chan) buffer($chan)
		return
	    }
	    watch {}
	    read {
		set n [lindex $args 1]
		set new [expr {$index($chan) + $n}]
		set result [string range $buffer($chan) $index($chan) $new-1]
		set index($chan) $new
		return $result
	    }
	}
    }
    set c [chan create read [namespace which driver]]
    chan configure $c -encoding utf-8 -translation lf -buffersize 107
    set out [makeFile {} out]
    set outChan [open $out w]
    chan configure $outChan -encoding utf-8 -translation lf
} -body {
9396
9397
9398
9399
9400
9401
9402
9403

9404




9405
9406
9407
9408
9409
9410
9411
9412
9413
9414


9415
9416
9417
9418
9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
9431

9432
9433
9434
9435
9436
9437
9438
9439
9440


9441
9442
9443
9444
9445
9446
9447
9412
9413
9414
9415
9416
9417
9418

9419
9420
9421
9422
9423
9424
9425
9426
9427
9428
9429
9430
9431
9432


9433
9434
9435
9436
9437
9438
9439
9440
9441
9442
9443
9444
9445
9446
9447
9448
9449
9450

9451
9452
9453
9454
9455
9456
9457
9458
9459

9460
9461
9462
9463
9464
9465
9466
9467
9468







-
+

+
+
+
+








-
-
+
+
















-
+








-
+
+







    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 -profile strict -buffering none
    fconfigure $f -encoding utf-8 -buffering none
} -body {
    catch {read $f} errmsg
    lappend res $errmsg
    seek $f 0
    chan configure $f -profile tcl8
    set d [read $f]
    binary scan $d H* hd
    lappend res $hd
    return $res
} -cleanup {
    close $f
    removeFile io-75.10
    unset result
} -returnCodes 1 -match glob -result {error reading "file*":\
    invalid or incomplete multibyte or wide character}
} -match glob -result {{error reading "file*":\
    invalid or incomplete multibyte or wide character} 41c0}

# The current result returns the orphan byte as byte.
# This may be expected due to special utf-8 handling.

# 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 -blocking 0 -eofchar {} -translation lf \
	-profile tcl8
	-profile strict
} -body {
    set d [read $f]
    binary scan $d H* hd
    lappend hd [catch {set d [read $f]} msg]
    lappend hd $msg
} -cleanup {
    close $f
    removeFile io-75.11
} -match glob -result {4181ff41 0 {}}
} -match glob -result {41 1 {error reading "file*":\
    invalid or incomplete multibyte or wide character}}

test io-75.12 {
    invalid utf-8 encoding read is not ignored because setting the encoding to
    "binary" also set the profile to strict
} -setup {
    set res {}
    set fn [makeFile {} io-75.12]
9510
9511
9512
9513
9514
9515
9516
9517
9518


9519
9520
9521
9522
9523
9524
9525
9531
9532
9533
9534
9535
9536
9537


9538
9539
9540
9541
9542
9543
9544
9545
9546







-
-
+
+







    set status [catch {gets $chan} cres copts]
    lappend res $status $cres
    chan configure $chan -profile tcl8
    lappend res [gets $chan]
    lappend res [gets $chan]
    close $chan
    return $res
} -returnCodes 1 -match glob -result {error reading "*":\
    invalid or incomplete multibyte or wide character}
} -match glob -result {a b 1 {error reading "*":\
    invalid or incomplete multibyte or wide character} cÀ d}

test io-75.15 {
    invalid utf-8 encoding strict
    gets does not hang
    gets succeeds for the first two lines
} -setup {
    set res {}
9545
9546
9547
9548
9549
9550
9551

9552

9553
9554
9555
9556
9557
9558
9559
9566
9567
9568
9569
9570
9571
9572
9573

9574
9575
9576
9577
9578
9579
9580
9581







+
-
+







	}
    fconfigure $chan -encoding utf-8 -profile strict -translation auto
	lappend res [gets $chan]
	lappend res [gets $chan]
    return $res
} -cleanup {
    close $chan
} -match glob -result {hello AB 1 {error reading "*": invalid or incomplete multibyte or wide character}\
} -returnCodes 1 -match glob -result {error reading "*": invalid or incomplete multibyte or wide character}
    1 {error reading "*": invalid or incomplete multibyte or wide character} 43 44 c0 40 EF GHI}

# ### ### ### ######### ######### #########



test io-76.0 {channel modes} -setup {
    set datafile [makeFile {some characters} dummy]