1# -*- tcl -*- 2# Commands covered: transform, and stacking in general 3# 4# This file contains a collection of tests for Giot 5# 6# See the file "license.terms" for information on usage and redistribution of 7# this file, and for a DISCLAIMER OF ALL WARRANTIES. 8# 9# Copyright © 2000 Ajuba Solutions. 10# Copyright © 2000 Andreas Kupries. 11# All rights reserved. 12 13if {"::tcltest" ni [namespace children]} { 14 package require tcltest 2.5 15 namespace import -force ::tcltest::* 16} 17 18::tcltest::loadTestedCommands 19catch [list package require -exact tcl::test [info patchlevel]] 20 21namespace eval ::tcl::test::iogt { 22 namespace import ::tcltest::* 23 24testConstraint testchannel [llength [info commands testchannel]] 25 26set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= 27} dummy] 28 29# " capture coloring of quotes 30 31set path(dummyout) [makeFile {} dummyout] 32 33set path(__echo_srv__.tcl) [makeFile { 34#!/usr/local/bin/tclsh 35# -*- tcl -*- 36# echo server 37# 38# arguments, options: port to listen on for connections. 39# delay till echo of first block 40# delay between blocks 41# blocksize ... 42 43set port [lindex $argv 0] 44set fdelay [lindex $argv 1] 45set idelay [lindex $argv 2] 46set bsizes [lrange $argv 3 end] 47set c 0 48 49proc newconn {sock rhost rport} { 50 variable fdelay 51 variable c 52 incr c 53 namespace upvar [namespace current] c$c conn 54 55 #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout 56 57 set conn(after) {} 58 set conn(state) 0 59 set conn(size) 0 60 set conn(data) "" 61 set conn(delay) $fdelay 62 63 fileevent $sock readable [list echoGet $c $sock] 64 fconfigure $sock -translation binary -buffering none -blocking 0 65} 66 67proc echoGet {c sock} { 68 variable fdelay 69 namespace upvar [namespace current] c$c conn 70 71 if {[eof $sock]} { 72 # one-shot echo 73 exit 74 } 75 append conn(data) [read $sock] 76 77 #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout 78 79 if {$conn(after) == {}} { 80 set conn(after) [after $conn(delay) [list echoPut $c $sock]] 81 } 82} 83 84proc echoPut {c sock} { 85 variable idelay 86 variable fdelay 87 variable bsizes 88 namespace upvar [namespace current] c$c conn 89 90 if {[string length $conn(data)] == 0} { 91 #puts stdout "C $c $sock" ; flush stdout 92 # auto terminate 93 close $sock 94 exit 95 #set conn(delay) $fdelay 96 return 97 } 98 99 set conn(delay) $idelay 100 set n [lindex $bsizes $conn(size)] 101 102 #puts stdout "P $c $sock $n >>" ; flush stdout 103 104 #puts __________________________________________ 105 #parray conn 106 #puts n=<$n> 107 108 if {[string length $conn(data)] >= $n} { 109 puts -nonewline $sock [string range $conn(data) 0 $n] 110 set conn(data) [string range $conn(data) [incr n] end] 111 } 112 113 incr conn(size) 114 if {$conn(size) >= [llength $bsizes]} { 115 set conn(size) [expr {[llength $bsizes]-1}] 116 } 117 118 set conn(after) [after $conn(delay) [list echoPut $c $sock]] 119} 120 121#fileevent stdin readable {exit ;#cut} 122 123# main 124socket -server newconn -myaddr 127.0.0.1 $port 125vwait forever 126} __echo_srv__.tcl] 127 128######################################################################## 129 130proc fevent {fdelay idelay blocks script data} { 131 # Start and initialize an echo server, prepare data transmission, then 132 # hand over to the test script. This has to start real transmission via 133 # 'flush'. The server is stopped after completion of the test. 134 135 upvar 1 sock sk 136 137 # Fixed port, not so good. Lets hope for the best, for now. 138 set port 4000 139 140 exec tclsh __echo_srv__.tcl $port $fdelay $idelay {*}$blocks >@stdout & 141 after 500 142 143 #puts stdout "> $port"; flush stdout 144 145 set sk [socket localhost $port] 146 fconfigure $sk -blocking 0 -buffering full \ 147 -buffersize [expr {10+[llength $data]}] 148 puts -nonewline $sk $data 149 150 # The channel is prepared to go off. 151 152 #puts stdout ">>>>>"; flush stdout 153 154 set res [uplevel 1 $script] 155 catch {close $sk} 156 return $res 157} 158 159# -------------------------------------------------------------- 160# utility transformations ... 161 162proc id {op data} { 163 switch -- $op { 164 create/write - create/read - delete/write - delete/read - clear_read { 165 #ignore 166 } 167 flush/write - flush/read - write - read { 168 return $data 169 } 170 query/maxRead { 171 return -1 172 } 173 } 174} 175 176proc id_optrail {var op data} { 177 variable $var 178 upvar 0 $var trail 179 180 lappend trail $op 181 switch -- $op { 182 create/write - create/read - delete/write - delete/read - 183 flush/read - clear/read { 184 #ignore 185 } 186 flush/write - write - read { 187 return $data 188 } 189 query/maxRead { 190 return -1 191 } 192 default { 193 lappend trail "error $op" 194 error $op 195 } 196 } 197} 198 199proc id_fulltrail {var op data} { 200 namespace upvar [namespace current] $var trail 201 202 #puts stdout ">> $var $op $data" ; flush stdout 203 204 switch -- $op { 205 create/write - create/read - delete/write - delete/read - clear_read { 206 set res *ignored* 207 } 208 flush/write - flush/read - write - read { 209 set res $data 210 } 211 query/maxRead { 212 set res -1 213 } 214 } 215 216 #catch {puts stdout "\t>* $res" ; flush stdout} 217 #catch {puts stdout "x$res"} msg 218 219 lappend trail [list $op $data $res] 220 return $res 221} 222 223proc id_torture {chan op data} { 224 switch -- $op { 225 create/write - 226 create/read - 227 delete/write - 228 delete/read - 229 clear_read {;#ignore} 230 flush/write - 231 flush/read {} 232 write { 233 global level 234 if {$level} { 235 return 236 } 237 incr level 238 testchannel unstack $chan 239 testchannel transform $chan \ 240 -command [namespace code [list id_torture $chan]] 241 return $data 242 } 243 read { 244 testchannel unstack $chan 245 testchannel transform $chan \ 246 -command [namespace code [list id_torture $chan]] 247 return $data 248 } 249 query/maxRead {return -1} 250 } 251} 252 253proc counter {var op data} { 254 namespace upvar [namespace current] $var n 255 256 switch -- $op { 257 create/write - create/read - delete/write - delete/read - clear_read { 258 #ignore 259 } 260 flush/write - flush/read { 261 return {} 262 } 263 write { 264 return $data 265 } 266 read { 267 if {$n > 0} { 268 incr n -[string length $data] 269 if {$n < 0} { 270 set n 0 271 } 272 } 273 return $data 274 } 275 query/maxRead { 276 return $n 277 } 278 } 279} 280 281proc counter_audit {var vtrail op data} { 282 namespace upvar [namespace current] $var n $vtrail trail 283 284 switch -- $op { 285 create/write - create/read - delete/write - delete/read - clear_read { 286 set res {} 287 } 288 flush/write - flush/read { 289 set res {} 290 } 291 write { 292 set res $data 293 } 294 read { 295 if {$n > 0} { 296 incr n -[string length $data] 297 if {$n < 0} { 298 set n 0 299 } 300 } 301 set res $data 302 } 303 query/maxRead { 304 set res $n 305 } 306 } 307 308 lappend trail [list counter:$op $data $res] 309 return $res 310} 311 312proc rblocks {var vtrail n op data} { 313 namespace upvar [namespace current] $var buf $vtrail trail 314 315 set res {} 316 317 switch -- $op { 318 create/write - create/read - delete/write - delete/read - clear_read { 319 set buf {} 320 } 321 flush/write { 322 } 323 flush/read { 324 set res $buf 325 set buf {} 326 } 327 write { 328 set data 329 } 330 read { 331 append buf $data 332 set b [expr {$n * ([string length $buf] / $n)}] 333 append op " $n [string length $buf] :- $b" 334 set res [string range $buf 0 [incr b -1]] 335 set buf [string range $buf [incr b] end] 336 #return $res 337 } 338 query/maxRead { 339 set res -1 340 } 341 } 342 343 lappend trail [list rblock | $op $data $res | $buf] 344 return $res 345} 346 347# -------------------------------------------------------------- 348# ... and convenience procedures to stack them 349 350proc identity {-attach channel} { 351 testchannel transform $channel -command [namespace code id] 352} 353proc audit_ops {var -attach channel} { 354 testchannel transform $channel -command [namespace code [list id_optrail $var]] 355} 356proc audit_flow {var -attach channel} { 357 testchannel transform $channel -command [namespace code [list id_fulltrail $var]] 358} 359 360proc torture {-attach channel} { 361 testchannel transform $channel -command [namespace code [list id_torture $channel]] 362} 363 364proc stopafter {var n -attach channel} { 365 namespace upvar [namespace current] $var vn 366 set vn $n 367 testchannel transform $channel -command [namespace code [list counter $var]] 368} 369proc stopafter_audit {var trail n -attach channel} { 370 namespace upvar [namespace current] $var vn 371 set vn $n 372 testchannel transform $channel -command [namespace code [list counter_audit $var $trail]] 373} 374proc rblocks_t {var trail n -attach channel} { 375 testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]] 376} 377 378# -------------------------------------------------------------- 379# serialize an array, with keys in sorted order. 380 381proc array_sget {v} { 382 upvar $v a 383 set res [list] 384 foreach n [lsort [array names a]] { 385 lappend res $n $a($n) 386 } 387 set res 388} 389proc asort {alist} { 390 # sort a list of key/value pairs by key, removes duplicates too. 391 array set a $alist 392 array_sget a 393} 394 395######################################################################## 396 397test iogt-1.1 {stack/unstack} testchannel { 398 set fh [open $path(dummy) r] 399 identity -attach $fh 400 testchannel unstack $fh 401 close $fh 402} {} 403test iogt-1.2 {stack/close} testchannel { 404 set fh [open $path(dummy) r] 405 identity -attach $fh 406 close $fh 407} {} 408test iogt-1.3 {stack/unstack, configuration, options} testchannel { 409 set fh [open $path(dummy) r] 410 set ca [asort [fconfigure $fh]] 411 identity -attach $fh 412 set cb [asort [fconfigure $fh]] 413 testchannel unstack $fh 414 set cc [asort [fconfigure $fh]] 415 close $fh 416 # With this system none of the buffering, translation and encoding option 417 # may change their values with channels stacked upon each other or not. 418 # cb == ca == cc 419 list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc] 420} {1 1 1} 421test iogt-1.4 {stack/unstack, configuration} -setup { 422 set fh [open $path(dummy) r] 423} -constraints testchannel -body { 424 set ca [asort [fconfigure $fh]] 425 identity -attach $fh 426 fconfigure $fh -buffering line -translation cr -encoding shiftjis 427 testchannel unstack $fh 428 set cc [asort [fconfigure $fh]] 429 list [string equal $ca $cc] [fconfigure $fh -buffering] \ 430 [fconfigure $fh -translation] [fconfigure $fh -encoding] 431} -cleanup { 432 close $fh 433} -result {0 line cr shiftjis} 434 435test iogt-2.0 {basic I/O going through transform} -setup { 436 set fin [open $path(dummy) r] 437 set fout [open $path(dummyout) w] 438} -constraints testchannel -body { 439 identity -attach $fin 440 identity -attach $fout 441 fcopy $fin $fout 442 close $fin 443 close $fout 444 set fin [open $path(dummy) r] 445 set fout [open $path(dummyout) r] 446 list [string equal [set in [read $fin]] [set out [read $fout]]] \ 447 [string length $in] [string length $out] 448} -cleanup { 449 close $fin 450 close $fout 451} -result {1 71 71} 452test iogt-2.1 {basic I/O, operation trail} {testchannel unix} { 453 set fin [open $path(dummy) r] 454 set fout [open $path(dummyout) w] 455 set ain [list]; set aout [list] 456 audit_ops ain -attach $fin 457 audit_ops aout -attach $fout 458 fconfigure $fin -buffersize 10 459 fconfigure $fout -buffersize 10 460 fcopy $fin $fout 461 close $fin 462 close $fout 463 set res "[join $ain \n]\n--------\n[join $aout \n]" 464} {create/read 465query/maxRead 466read 467query/maxRead 468read 469query/maxRead 470read 471query/maxRead 472read 473query/maxRead 474read 475query/maxRead 476read 477query/maxRead 478read 479query/maxRead 480read 481query/maxRead 482flush/read 483query/maxRead 484delete/read 485-------- 486create/write 487write 488write 489write 490write 491write 492write 493write 494write 495flush/write 496delete/write} 497test iogt-2.2 {basic I/O, data trail} {testchannel unix} { 498 set fin [open $path(dummy) r] 499 set fout [open $path(dummyout) w] 500 set ain [list]; set aout [list] 501 audit_flow ain -attach $fin 502 audit_flow aout -attach $fout 503 fconfigure $fin -buffersize 10 504 fconfigure $fout -buffersize 10 505 fcopy $fin $fout 506 close $fin 507 close $fout 508 set res "[join $ain \n]\n--------\n[join $aout \n]" 509} {create/read {} *ignored* 510query/maxRead {} -1 511read abcdefghij abcdefghij 512query/maxRead {} -1 513read klmnopqrst klmnopqrst 514query/maxRead {} -1 515read uvwxyz0123 uvwxyz0123 516query/maxRead {} -1 517read 456789,./? 456789,./? 518query/maxRead {} -1 519read {><;'\|":[]} {><;'\|":[]} 520query/maxRead {} -1 521read {\}\{`~!@#$} {\}\{`~!@#$} 522query/maxRead {} -1 523read %^&*()_+-= %^&*()_+-= 524query/maxRead {} -1 525read { 526} { 527} 528query/maxRead {} -1 529flush/read {} {} 530query/maxRead {} -1 531delete/read {} *ignored* 532-------- 533create/write {} *ignored* 534write abcdefghij abcdefghij 535write klmnopqrst klmnopqrst 536write uvwxyz0123 uvwxyz0123 537write 456789,./? 456789,./? 538write {><;'\|":[]} {><;'\|":[]} 539write {\}\{`~!@#$} {\}\{`~!@#$} 540write %^&*()_+-= %^&*()_+-= 541write { 542} { 543} 544flush/write {} {} 545delete/write {} *ignored*} 546test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} { 547 set fin [open $path(dummy) r] 548 set fout [open $path(dummyout) w] 549 set trail [list] 550 audit_flow trail -attach $fin 551 audit_flow trail -attach $fout 552 fconfigure $fin -buffersize 20 553 fconfigure $fout -buffersize 10 554 fcopy $fin $fout 555 close $fin 556 close $fout 557 join $trail \n 558} {create/read {} *ignored* 559create/write {} *ignored* 560query/maxRead {} -1 561read abcdefghijklmnopqrst abcdefghijklmnopqrst 562write abcdefghij abcdefghij 563write klmnopqrst klmnopqrst 564query/maxRead {} -1 565read uvwxyz0123456789,./? uvwxyz0123456789,./? 566write uvwxyz0123 uvwxyz0123 567write 456789,./? 456789,./? 568query/maxRead {} -1 569read {><;'\|":[]\}\{`~!@#$} {><;'\|":[]\}\{`~!@#$} 570write {><;'\|":[]} {><;'\|":[]} 571write {\}\{`~!@#$} {\}\{`~!@#$} 572query/maxRead {} -1 573read {%^&*()_+-= 574} {%^&*()_+-= 575} 576query/maxRead {} -1 577flush/read {} {} 578write %^&*()_+-= %^&*()_+-= 579write { 580} { 581} 582query/maxRead {} -1 583delete/read {} *ignored* 584flush/write {} {} 585delete/write {} *ignored*} 586 587test iogt-2.4 {basic I/O, mixed trail} {testchannel} { 588 set fh [open $path(dummy) r] 589 torture -attach $fh 590 chan configure $fh -buffersize 2 591 set x [read $fh] 592 testchannel unstack $fh 593 close $fh 594 set x 595} {} 596test iogt-2.5 {basic I/O, mixed trail} {testchannel} { 597 set ::level 0 598 set fh [open $path(dummyout) w] 599 torture -attach $fh 600 puts -nonewline $fh abcdef 601 flush $fh 602 testchannel unstack $fh 603 close $fh 604} {} 605 606test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { 607 proc DoneCopy {n {err {}}} { 608 variable copy 1 609 } 610} -constraints {testchannel knownBug} -body { 611 # This test to check the validity of acquired Tcl_Channel references is not 612 # possible because even a backgrounded fcopy will immediately start to 613 # copy data, without waiting for the event loop. This is done only in case 614 # of an underflow on the read size!. So stacking transforms after the 615 # fcopy will miss information, or are not used at all. 616 # 617 # I was able to circumvent this by using the echo.tcl server with a big 618 # delay, causing the fcopy to underflow immediately. 619 set fin [open $path(dummy) r] 620 fevent 1000 500 {20 20 20 10 1 1} { 621 variable copy 622 close $fin 623 set fout [open dummyout w] 624 flush $sock; # now, or fcopy will error us out 625 # But the 1 second delay should be enough to initialize everything 626 # else here. 627 fcopy $sock $fout -command [namespace code DoneCopy] 628 # Transform after fcopy got its handles! They should be still valid 629 # for fcopy. 630 set trail [list] 631 audit_ops trail -attach $fout 632 vwait [namespace which -variable copy] 633 } [read $fin]; # {} 634 close $fout 635 # Check result of copy. 636 set fin [open $path(dummy) r] 637 set fout [open $path(dummyout) r] 638 set res [string equal [read $fin] [read $fout]] 639 close $fin 640 close $fout 641 list $res $trail 642} -cleanup { 643 rename DoneCopy {} 644} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}} 645 646test iogt-4.0 {fileevent readable, after transform} -setup { 647 set fin [open $path(dummy) r] 648 set data [read $fin] 649 close $fin 650 set trail [list] 651 set got [list] 652 proc Done {args} { 653 variable stop 1 654 } 655 proc Get {sock} { 656 variable trail 657 variable got 658 if {[eof $sock]} { 659 Done 660 lappend trail "xxxxxxxxxxxxx" 661 close $sock 662 return 663 } 664 lappend trail "vvvvvvvvvvvvv" 665 lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" 666 lappend trail "=============" 667 #puts stdout $__ ; flush stdout 668 #read $sock 669 } 670 671} -constraints {testchannel knownBug} -body { 672 fevent 1000 500 {20 20 20 10 1} { 673 variable stop 674 audit_flow trail -attach $sock 675 rblocks_t rbuf trail 23 -attach $sock 676 677 fileevent $sock readable [namespace code [list Get $sock]] 678 679 flush $sock; # Now, or fcopy will error us out 680 # But the 1 second delay should be enough to initialize everything 681 # else here. 682 vwait [namespace which -variable stop] 683 } $data 684 join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n 685} -cleanup { 686 rename Done {} 687 rename Get {} 688} -result {[[]] 689[[abcdefghijklmnopqrstuvw]] 690[[xyz0123456789,./?><;'\|]] 691[[]] 692[[]] 693[[":[]\}\{`~!@#$%^&*()]] 694[[]] 695~~~~~~~~ 696create/write {} *ignored* 697create/read {} *ignored* 698rblock | create/write {} {} | {} 699rblock | create/read {} {} | {} 700vvvvvvvvvvvvv 701rblock | query/maxRead {} -1 | {} 702query/maxRead {} -1 703read abcdefghijklmnopqrstu abcdefghijklmnopqrstu 704query/maxRead {} -1 705rblock | {read 23 21 :- 0} abcdefghijklmnopqrstu {} | abcdefghijklmnopqrstu 706rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu 707query/maxRead {} -1 708 got: {[[]]} 709============= 710vvvvvvvvvvvvv 711rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu 712query/maxRead {} -1 713read vwxyz0123456789,./?>< vwxyz0123456789,./?>< 714query/maxRead {} -1 715rblock | {read 23 42 :- 23} vwxyz0123456789,./?>< abcdefghijklmnopqrstuvw | xyz0123456789,./?>< 716rblock | query/maxRead {} -1 | xyz0123456789,./?>< 717query/maxRead {} -1 718 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} 719============= 720vvvvvvvvvvvvv 721rblock | query/maxRead {} -1 | xyz0123456789,./?>< 722query/maxRead {} -1 723read {;'\|":[]\}\{`~!@#$%^&} {;'\|":[]\}\{`~!@#$%^&} 724query/maxRead {} -1 725rblock | {read 23 40 :- 23} {;'\|":[]\}\{`~!@#$%^&} {xyz0123456789,./?><;'\|} | {":[]\}\{`~!@#$%^&} 726rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&} 727query/maxRead {} -1 728 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} 729============= 730vvvvvvvvvvvvv 731rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&} 732query/maxRead {} -1 733read *( *( 734query/maxRead {} -1 735rblock | {read 23 19 :- 0} *( {} | {":[]\}\{`~!@#$%^&*(} 736rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(} 737query/maxRead {} -1 738 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} 739============= 740vvvvvvvvvvvvv 741rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(} 742query/maxRead {} -1 743read ) ) 744query/maxRead {} -1 745rblock | {read 23 20 :- 0} ) {} | {":[]\}\{`~!@#$%^&*()} 746rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()} 747query/maxRead {} -1 748 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} 749============= 750vvvvvvvvvvvvv 751rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()} 752query/maxRead {} -1 753flush/read {} {} 754rblock | flush/read {} {":[]\}\{`~!@#$%^&*()} | {} 755rblock | query/maxRead {} -1 | {} 756query/maxRead {} -1 757 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]} 758============= 759vvvvvvvvvvvvv 760rblock | query/maxRead {} -1 | {} 761query/maxRead {} -1 762 got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]} {[[]]} 763xxxxxxxxxxxxx 764rblock | flush/write {} {} | {} 765rblock | delete/write {} {} | {} 766rblock | delete/read {} {} | {} 767flush/write {} {} 768delete/write {} *ignored* 769delete/read {} *ignored*}; # catch unescaped quote " 770 771test iogt-5.0 {EOF simulation} -setup { 772 set fin [open $path(dummy) r] 773 set fout [open $path(dummyout) w] 774 set trail [list] 775} -constraints {testchannel knownBug} -result { 776 audit_flow trail -attach $fin 777 stopafter_audit d trail 20 -attach $fin 778 audit_flow trail -attach $fout 779 fconfigure $fin -buffersize 20 780 fconfigure $fout -buffersize 10 781 fcopy $fin $fout 782 testchannel unstack $fin 783 # now copy the rest in the channel 784 lappend trail {**after unstack**} 785 fcopy $fin $fout 786 close $fin 787 close $fout 788 join $trail \n 789} -result {create/read {} *ignored* 790counter:create/read {} {} 791create/write {} *ignored* 792counter:query/maxRead {} 20 793query/maxRead {} -1 794read {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= 795} {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-= 796} 797query/maxRead {} -1 798flush/read {} {} 799counter:read abcdefghijklmnopqrst abcdefghijklmnopqrst 800write abcdefghij abcdefghij 801write klmnopqrst klmnopqrst 802counter:query/maxRead {} 0 803counter:flush/read {} {} 804counter:delete/read {} {} 805**after unstack** 806query/maxRead {} -1 807write uvwxyz0123 uvwxyz0123 808write 456789,./? 456789,./? 809write {><;'\|":[]} {><;'\|":[]} 810write {\}\{`~!@#$} {\}\{`~!@#$} 811write %^&*()_+-= %^&*()_+-= 812write { 813} { 814} 815query/maxRead {} -1 816delete/read {} *ignored* 817flush/write {} {} 818delete/write {} *ignored*} 819 820proc constX {op data} { 821 # replace anything coming in with a same-length string of x'es. 822 switch -- $op { 823 create/write - create/read - delete/write - delete/read - clear_read { 824 #ignore 825 } 826 flush/write - flush/read - write - read { 827 return [string repeat x [string length $data]] 828 } 829 query/maxRead { 830 return -1 831 } 832 } 833} 834proc constx {-attach channel} { 835 testchannel transform $channel -command [namespace code constX] 836} 837 838test iogt-6.0 {Push back} -constraints testchannel -body { 839 set f [open $path(dummy) r] 840 # contents of dummy = "abcdefghi..." 841 read $f 3; # skip behind "abc" 842 constx -attach $f 843 # expect to get "xxx" from the transform because of unread "def" input to 844 # transform which returns "xxx". 845 # 846 # Actually the IO layer pre-read the whole file and will read "def" 847 # directly from the buffer without bothering to consult the newly stacked 848 # transformation. This is wrong. 849 read $f 3 850} -cleanup { 851 close $f 852} -result {xxx} 853test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body { 854 855 # This test demonstrates the bug/misfeature in the stacked 856 # channel implementation that data can be discarded if it is 857 # read into the buffers of one channel in the stack, and then 858 # that channel is popped before anything above it reads. 859 # 860 # This bug can be worked around by always setting -buffersize 861 # to 1, but who wants to do that? 862 863 set f [open $path(dummy) r] 864 # contents of dummy = "abcdefghi..." 865 read $f 3; # skip behind "abc" 866 constx -attach $f 867 set res [read $f 3] 868 testchannel unstack $f 869 append res [read $f 3] 870} -cleanup { 871 close $f 872} -result {xxxghi} 873 874 875# Driver for a base channel that emits several short "files" 876# with each terminated by a fleeting EOF 877 proc driver {cmd args} { 878 variable buffer 879 variable index 880 set chan [lindex $args 0] 881 switch -- $cmd { 882 initialize { 883 set index($chan) 0 884 set buffer($chan) ..... 885 return {initialize finalize watch read} 886 } 887 finalize { 888 if {![info exists index($chan)]} {return} 889 unset index($chan) buffer($chan) 890 return 891 } 892 watch {} 893 read { 894 set n [lindex $args 1] 895 if {![info exists index($chan)]} { 896 driver initialize $chan 897 } 898 set new [expr {$index($chan) + $n}] 899 set result [string range $buffer($chan) $index($chan) $new-1] 900 set index($chan) $new 901 if {[string length $result] == 0} { 902 driver finalize $chan 903 } 904 return $result 905 } 906 } 907 } 908 909test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body { 910 set chan [chan create read [namespace which driver]] 911 identity -attach $chan 912 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 913 [read $chan] [eof $chan] 914} -cleanup { 915 close $chan 916} -result {0 ..... 1 {} 0 ..... 1} 917 918proc delay {op data} { 919 variable store 920 switch -- $op { 921 create/write - create/read - 922 delete/write - delete/read - 923 flush/write - write - 924 clear_read {;#ignore} 925 flush/read - 926 read { 927 if {![info exists store]} {set store {}} 928 set reply $store 929 set store $data 930 return $reply 931 } 932 query/maxRead {return -1} 933 } 934} 935 936test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body { 937 set chan [chan create read [namespace which driver]] 938 testchannel transform $chan -command [namespace code delay] 939 list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \ 940 [read $chan] [eof $chan] 941} -cleanup { 942 close $chan 943} -result {0 ..... 1 {} 0 ..... 1} 944 945rename delay {} 946rename driver {} 947 948# cleanup 949foreach file [list dummy dummyout __echo_srv__.tcl] { 950 removeFile $file 951} 952cleanupTests 953} 954namespace delete ::tcl::test::iogt 955return 956