summaryrefslogtreecommitdiffstats
path: root/tcl8.6/tests/iogt.test
diff options
context:
space:
mode:
Diffstat (limited to 'tcl8.6/tests/iogt.test')
-rw-r--r--tcl8.6/tests/iogt.test955
1 files changed, 955 insertions, 0 deletions
diff --git a/tcl8.6/tests/iogt.test b/tcl8.6/tests/iogt.test
new file mode 100644
index 0000000..269a0ba
--- /dev/null
+++ b/tcl8.6/tests/iogt.test
@@ -0,0 +1,955 @@
+# -*- tcl -*-
+# Commands covered: transform, and stacking in general
+#
+# This file contains a collection of tests for Giot
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# Copyright (c) 2000 Ajuba Solutions.
+# Copyright (c) 2000 Andreas Kupries.
+# All rights reserved.
+
+if {[catch {package require tcltest 2.1}]} {
+ puts stderr "Skipping tests in [info script]. tcltest 2.1 required."
+ return
+}
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+namespace eval ::tcl::test::iogt {
+ namespace import ::tcltest::*
+
+testConstraint testchannel [llength [info commands testchannel]]
+
+set path(dummy) [makeFile {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
+} dummy]
+
+# " capture coloring of quotes
+
+set path(dummyout) [makeFile {} dummyout]
+
+set path(__echo_srv__.tcl) [makeFile {
+#!/usr/local/bin/tclsh
+# -*- tcl -*-
+# echo server
+#
+# arguments, options: port to listen on for connections.
+# delay till echo of first block
+# delay between blocks
+# blocksize ...
+
+set port [lindex $argv 0]
+set fdelay [lindex $argv 1]
+set idelay [lindex $argv 2]
+set bsizes [lrange $argv 3 end]
+set c 0
+
+proc newconn {sock rhost rport} {
+ variable fdelay
+ variable c
+ incr c
+ namespace upvar [namespace current] c$c conn
+
+ #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout
+
+ set conn(after) {}
+ set conn(state) 0
+ set conn(size) 0
+ set conn(data) ""
+ set conn(delay) $fdelay
+
+ fileevent $sock readable [list echoGet $c $sock]
+ fconfigure $sock -translation binary -buffering none -blocking 0
+}
+
+proc echoGet {c sock} {
+ variable fdelay
+ namespace upvar [namespace current] c$c conn
+
+ if {[eof $sock]} {
+ # one-shot echo
+ exit
+ }
+ append conn(data) [read $sock]
+
+ #puts stdout "G $c $sock $conn(data) <<$conn(data)>>" ; flush stdout
+
+ if {$conn(after) == {}} {
+ set conn(after) [after $conn(delay) [list echoPut $c $sock]]
+ }
+}
+
+proc echoPut {c sock} {
+ variable idelay
+ variable fdelay
+ variable bsizes
+ namespace upvar [namespace current] c$c conn
+
+ if {[string length $conn(data)] == 0} {
+ #puts stdout "C $c $sock" ; flush stdout
+ # auto terminate
+ close $sock
+ exit
+ #set conn(delay) $fdelay
+ return
+ }
+
+ set conn(delay) $idelay
+ set n [lindex $bsizes $conn(size)]
+
+ #puts stdout "P $c $sock $n >>" ; flush stdout
+
+ #puts __________________________________________
+ #parray conn
+ #puts n=<$n>
+
+ if {[string length $conn(data)] >= $n} {
+ puts -nonewline $sock [string range $conn(data) 0 $n]
+ set conn(data) [string range $conn(data) [incr n] end]
+ }
+
+ incr conn(size)
+ if {$conn(size) >= [llength $bsizes]} {
+ set conn(size) [expr {[llength $bsizes]-1}]
+ }
+
+ set conn(after) [after $conn(delay) [list echoPut $c $sock]]
+}
+
+#fileevent stdin readable {exit ;#cut}
+
+# main
+socket -server newconn -myaddr 127.0.0.1 $port
+vwait forever
+} __echo_srv__.tcl]
+
+########################################################################
+
+proc fevent {fdelay idelay blocks script data} {
+ # Start and initialize an echo server, prepare data transmission, then
+ # hand over to the test script. This has to start real transmission via
+ # 'flush'. The server is stopped after completion of the test.
+
+ upvar 1 sock sk
+
+ # Fixed port, not so good. Lets hope for the best, for now.
+ set port 4000
+
+ exec tclsh __echo_srv__.tcl $port $fdelay $idelay {*}$blocks >@stdout &
+ after 500
+
+ #puts stdout "> $port"; flush stdout
+
+ set sk [socket localhost $port]
+ fconfigure $sk -blocking 0 -buffering full \
+ -buffersize [expr {10+[llength $data]}]
+ puts -nonewline $sk $data
+
+ # The channel is prepared to go off.
+
+ #puts stdout ">>>>>"; flush stdout
+
+ set res [uplevel 1 $script]
+ catch {close $sk}
+ return $res
+}
+
+# --------------------------------------------------------------
+# utility transformations ...
+
+proc id {op data} {
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ #ignore
+ }
+ flush/write - flush/read - write - read {
+ return $data
+ }
+ query/maxRead {
+ return -1
+ }
+ }
+}
+
+proc id_optrail {var op data} {
+ variable $var
+ upvar 0 $var trail
+
+ lappend trail $op
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read -
+ flush/read - clear/read {
+ #ignore
+ }
+ flush/write - write - read {
+ return $data
+ }
+ query/maxRead {
+ return -1
+ }
+ default {
+ lappend trail "error $op"
+ error $op
+ }
+ }
+}
+
+proc id_fulltrail {var op data} {
+ namespace upvar [namespace current] $var trail
+
+ #puts stdout ">> $var $op $data" ; flush stdout
+
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ set res *ignored*
+ }
+ flush/write - flush/read - write - read {
+ set res $data
+ }
+ query/maxRead {
+ set res -1
+ }
+ }
+
+ #catch {puts stdout "\t>* $res" ; flush stdout}
+ #catch {puts stdout "x$res"} msg
+
+ lappend trail [list $op $data $res]
+ return $res
+}
+
+proc id_torture {chan op data} {
+ switch -- $op {
+ create/write -
+ create/read -
+ delete/write -
+ delete/read -
+ clear_read {;#ignore}
+ flush/write -
+ flush/read {}
+ write {
+ global level
+ if {$level} {
+ return
+ }
+ incr level
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ read {
+ testchannel unstack $chan
+ testchannel transform $chan \
+ -command [namespace code [list id_torture $chan]]
+ return $data
+ }
+ query/maxRead {return -1}
+ }
+}
+
+proc counter {var op data} {
+ namespace upvar [namespace current] $var n
+
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ #ignore
+ }
+ flush/write - flush/read {
+ return {}
+ }
+ write {
+ return $data
+ }
+ read {
+ if {$n > 0} {
+ incr n -[string length $data]
+ if {$n < 0} {
+ set n 0
+ }
+ }
+ return $data
+ }
+ query/maxRead {
+ return $n
+ }
+ }
+}
+
+proc counter_audit {var vtrail op data} {
+ namespace upvar [namespace current] $var n $vtrail trail
+
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ set res {}
+ }
+ flush/write - flush/read {
+ set res {}
+ }
+ write {
+ set res $data
+ }
+ read {
+ if {$n > 0} {
+ incr n -[string length $data]
+ if {$n < 0} {
+ set n 0
+ }
+ }
+ set res $data
+ }
+ query/maxRead {
+ set res $n
+ }
+ }
+
+ lappend trail [list counter:$op $data $res]
+ return $res
+}
+
+proc rblocks {var vtrail n op data} {
+ namespace upvar [namespace current] $var buf $vtrail trail
+
+ set res {}
+
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ set buf {}
+ }
+ flush/write {
+ }
+ flush/read {
+ set res $buf
+ set buf {}
+ }
+ write {
+ set data
+ }
+ read {
+ append buf $data
+ set b [expr {$n * ([string length $buf] / $n)}]
+ append op " $n [string length $buf] :- $b"
+ set res [string range $buf 0 [incr b -1]]
+ set buf [string range $buf [incr b] end]
+ #return $res
+ }
+ query/maxRead {
+ set res -1
+ }
+ }
+
+ lappend trail [list rblock | $op $data $res | $buf]
+ return $res
+}
+
+# --------------------------------------------------------------
+# ... and convenience procedures to stack them
+
+proc identity {-attach channel} {
+ testchannel transform $channel -command [namespace code id]
+}
+proc audit_ops {var -attach channel} {
+ testchannel transform $channel -command [namespace code [list id_optrail $var]]
+}
+proc audit_flow {var -attach channel} {
+ testchannel transform $channel -command [namespace code [list id_fulltrail $var]]
+}
+
+proc torture {-attach channel} {
+ testchannel transform $channel -command [namespace code [list id_torture $channel]]
+}
+
+proc stopafter {var n -attach channel} {
+ namespace upvar [namespace current] $var vn
+ set vn $n
+ testchannel transform $channel -command [namespace code [list counter $var]]
+}
+proc stopafter_audit {var trail n -attach channel} {
+ namespace upvar [namespace current] $var vn
+ set vn $n
+ testchannel transform $channel -command [namespace code [list counter_audit $var $trail]]
+}
+proc rblocks_t {var trail n -attach channel} {
+ testchannel transform $channel -command [namespace code [list rblocks $var $trail $n]]
+}
+
+# --------------------------------------------------------------
+# serialize an array, with keys in sorted order.
+
+proc array_sget {v} {
+ upvar $v a
+ set res [list]
+ foreach n [lsort [array names a]] {
+ lappend res $n $a($n)
+ }
+ set res
+}
+proc asort {alist} {
+ # sort a list of key/value pairs by key, removes duplicates too.
+ array set a $alist
+ array_sget a
+}
+
+########################################################################
+
+test iogt-1.1 {stack/unstack} testchannel {
+ set fh [open $path(dummy) r]
+ identity -attach $fh
+ testchannel unstack $fh
+ close $fh
+} {}
+test iogt-1.2 {stack/close} testchannel {
+ set fh [open $path(dummy) r]
+ identity -attach $fh
+ close $fh
+} {}
+test iogt-1.3 {stack/unstack, configuration, options} testchannel {
+ set fh [open $path(dummy) r]
+ set ca [asort [fconfigure $fh]]
+ identity -attach $fh
+ set cb [asort [fconfigure $fh]]
+ testchannel unstack $fh
+ set cc [asort [fconfigure $fh]]
+ close $fh
+ # With this system none of the buffering, translation and encoding option
+ # may change their values with channels stacked upon each other or not.
+ # cb == ca == cc
+ list [string equal $ca $cb] [string equal $cb $cc] [string equal $ca $cc]
+} {1 1 1}
+test iogt-1.4 {stack/unstack, configuration} -setup {
+ set fh [open $path(dummy) r]
+} -constraints testchannel -body {
+ set ca [asort [fconfigure $fh]]
+ identity -attach $fh
+ fconfigure $fh -buffering line -translation cr -encoding shiftjis
+ testchannel unstack $fh
+ set cc [asort [fconfigure $fh]]
+ list [string equal $ca $cc] [fconfigure $fh -buffering] \
+ [fconfigure $fh -translation] [fconfigure $fh -encoding]
+} -cleanup {
+ close $fh
+} -result {0 line cr shiftjis}
+
+test iogt-2.0 {basic I/O going through transform} -setup {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
+} -constraints testchannel -body {
+ identity -attach $fin
+ identity -attach $fout
+ fcopy $fin $fout
+ close $fin
+ close $fout
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) r]
+ list [string equal [set in [read $fin]] [set out [read $fout]]] \
+ [string length $in] [string length $out]
+} -cleanup {
+ close $fin
+ close $fout
+} -result {1 71 71}
+test iogt-2.1 {basic I/O, operation trail} {testchannel unix} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
+ set ain [list]; set aout [list]
+ audit_ops ain -attach $fin
+ audit_ops aout -attach $fout
+ fconfigure $fin -buffersize 10
+ fconfigure $fout -buffersize 10
+ fcopy $fin $fout
+ close $fin
+ close $fout
+ set res "[join $ain \n]\n--------\n[join $aout \n]"
+} {create/read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+read
+query/maxRead
+flush/read
+query/maxRead
+delete/read
+--------
+create/write
+write
+write
+write
+write
+write
+write
+write
+write
+flush/write
+delete/write}
+test iogt-2.2 {basic I/O, data trail} {testchannel unix} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
+ set ain [list]; set aout [list]
+ audit_flow ain -attach $fin
+ audit_flow aout -attach $fout
+ fconfigure $fin -buffersize 10
+ fconfigure $fout -buffersize 10
+ fcopy $fin $fout
+ close $fin
+ close $fout
+ set res "[join $ain \n]\n--------\n[join $aout \n]"
+} {create/read {} *ignored*
+query/maxRead {} -1
+read abcdefghij abcdefghij
+query/maxRead {} -1
+read klmnopqrst klmnopqrst
+query/maxRead {} -1
+read uvwxyz0123 uvwxyz0123
+query/maxRead {} -1
+read 456789,./? 456789,./?
+query/maxRead {} -1
+read {><;'\|":[]} {><;'\|":[]}
+query/maxRead {} -1
+read {\}\{`~!@#$} {\}\{`~!@#$}
+query/maxRead {} -1
+read %^&*()_+-= %^&*()_+-=
+query/maxRead {} -1
+read {
+} {
+}
+query/maxRead {} -1
+flush/read {} {}
+query/maxRead {} -1
+delete/read {} *ignored*
+--------
+create/write {} *ignored*
+write abcdefghij abcdefghij
+write klmnopqrst klmnopqrst
+write uvwxyz0123 uvwxyz0123
+write 456789,./? 456789,./?
+write {><;'\|":[]} {><;'\|":[]}
+write {\}\{`~!@#$} {\}\{`~!@#$}
+write %^&*()_+-= %^&*()_+-=
+write {
+} {
+}
+flush/write {} {}
+delete/write {} *ignored*}
+test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
+ set trail [list]
+ audit_flow trail -attach $fin
+ audit_flow trail -attach $fout
+ fconfigure $fin -buffersize 20
+ fconfigure $fout -buffersize 10
+ fcopy $fin $fout
+ close $fin
+ close $fout
+ join $trail \n
+} {create/read {} *ignored*
+create/write {} *ignored*
+query/maxRead {} -1
+read abcdefghijklmnopqrst abcdefghijklmnopqrst
+write abcdefghij abcdefghij
+write klmnopqrst klmnopqrst
+query/maxRead {} -1
+read uvwxyz0123456789,./? uvwxyz0123456789,./?
+write uvwxyz0123 uvwxyz0123
+write 456789,./? 456789,./?
+query/maxRead {} -1
+read {><;'\|":[]\}\{`~!@#$} {><;'\|":[]\}\{`~!@#$}
+write {><;'\|":[]} {><;'\|":[]}
+write {\}\{`~!@#$} {\}\{`~!@#$}
+query/maxRead {} -1
+read {%^&*()_+-=
+} {%^&*()_+-=
+}
+query/maxRead {} -1
+flush/read {} {}
+write %^&*()_+-= %^&*()_+-=
+write {
+} {
+}
+query/maxRead {} -1
+delete/read {} *ignored*
+flush/write {} {}
+delete/write {} *ignored*}
+
+test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
+ set fh [open $path(dummy) r]
+ torture -attach $fh
+ chan configure $fh -buffersize 2
+ set x [read $fh]
+ testchannel unstack $fh
+ close $fh
+ set x
+} {}
+test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
+ set ::level 0
+ set fh [open $path(dummyout) w]
+ torture -attach $fh
+ puts -nonewline $fh abcdef
+ flush $fh
+ testchannel unstack $fh
+ close $fh
+} {}
+
+test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
+ proc DoneCopy {n {err {}}} {
+ variable copy 1
+ }
+} -constraints {testchannel knownBug} -body {
+ # This test to check the validity of acquired Tcl_Channel references is not
+ # possible because even a backgrounded fcopy will immediately start to
+ # copy data, without waiting for the event loop. This is done only in case
+ # of an underflow on the read size!. So stacking transforms after the
+ # fcopy will miss information, or are not used at all.
+ #
+ # I was able to circumvent this by using the echo.tcl server with a big
+ # delay, causing the fcopy to underflow immediately.
+ set fin [open $path(dummy) r]
+ fevent 1000 500 {20 20 20 10 1 1} {
+ variable copy
+ close $fin
+ set fout [open dummyout w]
+ flush $sock; # now, or fcopy will error us out
+ # But the 1 second delay should be enough to initialize everything
+ # else here.
+ fcopy $sock $fout -command [namespace code DoneCopy]
+ # Transform after fcopy got its handles! They should be still valid
+ # for fcopy.
+ set trail [list]
+ audit_ops trail -attach $fout
+ vwait [namespace which -variable copy]
+ } [read $fin]; # {}
+ close $fout
+ # Check result of copy.
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) r]
+ set res [string equal [read $fin] [read $fout]]
+ close $fin
+ close $fout
+ list $res $trail
+} -cleanup {
+ rename DoneCopy {}
+} -result {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
+
+test iogt-4.0 {fileevent readable, after transform} -setup {
+ set fin [open $path(dummy) r]
+ set data [read $fin]
+ close $fin
+ set trail [list]
+ set got [list]
+ proc Done {args} {
+ variable stop 1
+ }
+ proc Get {sock} {
+ variable trail
+ variable got
+ if {[eof $sock]} {
+ Done
+ lappend trail "xxxxxxxxxxxxx"
+ close $sock
+ return
+ }
+ lappend trail "vvvvvvvvvvvvv"
+ lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]"
+ lappend trail "============="
+ #puts stdout $__ ; flush stdout
+ #read $sock
+ }
+
+} -constraints {testchannel knownBug} -body {
+ fevent 1000 500 {20 20 20 10 1} {
+ variable stop
+ audit_flow trail -attach $sock
+ rblocks_t rbuf trail 23 -attach $sock
+
+ fileevent $sock readable [namespace code [list Get $sock]]
+
+ flush $sock; # Now, or fcopy will error us out
+ # But the 1 second delay should be enough to initialize everything
+ # else here.
+ vwait [namespace which -variable stop]
+ } $data
+ join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
+} -cleanup {
+ rename Done {}
+ rename Get {}
+} -result {[[]]
+[[abcdefghijklmnopqrstuvw]]
+[[xyz0123456789,./?><;'\|]]
+[[]]
+[[]]
+[[":[]\}\{`~!@#$%^&*()]]
+[[]]
+~~~~~~~~
+create/write {} *ignored*
+create/read {} *ignored*
+rblock | create/write {} {} | {}
+rblock | create/read {} {} | {}
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | {}
+query/maxRead {} -1
+read abcdefghijklmnopqrstu abcdefghijklmnopqrstu
+query/maxRead {} -1
+rblock | {read 23 21 :- 0} abcdefghijklmnopqrstu {} | abcdefghijklmnopqrstu
+rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu
+query/maxRead {} -1
+ got: {[[]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | abcdefghijklmnopqrstu
+query/maxRead {} -1
+read vwxyz0123456789,./?>< vwxyz0123456789,./?><
+query/maxRead {} -1
+rblock | {read 23 42 :- 23} vwxyz0123456789,./?>< abcdefghijklmnopqrstuvw | xyz0123456789,./?><
+rblock | query/maxRead {} -1 | xyz0123456789,./?><
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | xyz0123456789,./?><
+query/maxRead {} -1
+read {;'\|":[]\}\{`~!@#$%^&} {;'\|":[]\}\{`~!@#$%^&}
+query/maxRead {} -1
+rblock | {read 23 40 :- 23} {;'\|":[]\}\{`~!@#$%^&} {xyz0123456789,./?><;'\|} | {":[]\}\{`~!@#$%^&}
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&}
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&}
+query/maxRead {} -1
+read *( *(
+query/maxRead {} -1
+rblock | {read 23 19 :- 0} *( {} | {":[]\}\{`~!@#$%^&*(}
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(}
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*(}
+query/maxRead {} -1
+read ) )
+query/maxRead {} -1
+rblock | {read 23 20 :- 0} ) {} | {":[]\}\{`~!@#$%^&*()}
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()}
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | {":[]\}\{`~!@#$%^&*()}
+query/maxRead {} -1
+flush/read {} {}
+rblock | flush/read {} {":[]\}\{`~!@#$%^&*()} | {}
+rblock | query/maxRead {} -1 | {}
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]}
+=============
+vvvvvvvvvvvvv
+rblock | query/maxRead {} -1 | {}
+query/maxRead {} -1
+ got: {[[]]} {[[abcdefghijklmnopqrstuvw]]} {[[xyz0123456789,./?><;'\|]]} {[[]]} {[[]]} {[[":[]\}\{`~!@#$%^&*()]]} {[[]]}
+xxxxxxxxxxxxx
+rblock | flush/write {} {} | {}
+rblock | delete/write {} {} | {}
+rblock | delete/read {} {} | {}
+flush/write {} {}
+delete/write {} *ignored*
+delete/read {} *ignored*}; # catch unescaped quote "
+
+test iogt-5.0 {EOF simulation} -setup {
+ set fin [open $path(dummy) r]
+ set fout [open $path(dummyout) w]
+ set trail [list]
+} -constraints {testchannel knownBug} -result {
+ audit_flow trail -attach $fin
+ stopafter_audit d trail 20 -attach $fin
+ audit_flow trail -attach $fout
+ fconfigure $fin -buffersize 20
+ fconfigure $fout -buffersize 10
+ fcopy $fin $fout
+ testchannel unstack $fin
+ # now copy the rest in the channel
+ lappend trail {**after unstack**}
+ fcopy $fin $fout
+ close $fin
+ close $fout
+ join $trail \n
+} -result {create/read {} *ignored*
+counter:create/read {} {}
+create/write {} *ignored*
+counter:query/maxRead {} 20
+query/maxRead {} -1
+read {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
+} {abcdefghijklmnopqrstuvwxyz0123456789,./?><;'\|":[]\}\{`~!@#$%^&*()_+-=
+}
+query/maxRead {} -1
+flush/read {} {}
+counter:read abcdefghijklmnopqrst abcdefghijklmnopqrst
+write abcdefghij abcdefghij
+write klmnopqrst klmnopqrst
+counter:query/maxRead {} 0
+counter:flush/read {} {}
+counter:delete/read {} {}
+**after unstack**
+query/maxRead {} -1
+write uvwxyz0123 uvwxyz0123
+write 456789,./? 456789,./?
+write {><;'\|":[]} {><;'\|":[]}
+write {\}\{`~!@#$} {\}\{`~!@#$}
+write %^&*()_+-= %^&*()_+-=
+write {
+} {
+}
+query/maxRead {} -1
+delete/read {} *ignored*
+flush/write {} {}
+delete/write {} *ignored*}
+
+proc constX {op data} {
+ # replace anything coming in with a same-length string of x'es.
+ switch -- $op {
+ create/write - create/read - delete/write - delete/read - clear_read {
+ #ignore
+ }
+ flush/write - flush/read - write - read {
+ return [string repeat x [string length $data]]
+ }
+ query/maxRead {
+ return -1
+ }
+ }
+}
+proc constx {-attach channel} {
+ testchannel transform $channel -command [namespace code constX]
+}
+
+test iogt-6.0 {Push back} -constraints testchannel -body {
+ set f [open $path(dummy) r]
+ # contents of dummy = "abcdefghi..."
+ read $f 3; # skip behind "abc"
+ constx -attach $f
+ # expect to get "xxx" from the transform because of unread "def" input to
+ # transform which returns "xxx".
+ #
+ # Actually the IO layer pre-read the whole file and will read "def"
+ # directly from the buffer without bothering to consult the newly stacked
+ # transformation. This is wrong.
+ read $f 3
+} -cleanup {
+ close $f
+} -result {xxx}
+test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
+
+ # This test demonstrates the bug/misfeature in the stacked
+ # channel implementation that data can be discarded if it is
+ # read into the buffers of one channel in the stack, and then
+ # that channel is popped before anything above it reads.
+ #
+ # This bug can be worked around by always setting -buffersize
+ # to 1, but who wants to do that?
+
+ set f [open $path(dummy) r]
+ # contents of dummy = "abcdefghi..."
+ read $f 3; # skip behind "abc"
+ constx -attach $f
+ set res [read $f 3]
+ testchannel unstack $f
+ append res [read $f 3]
+} -cleanup {
+ close $f
+} -result {xxxghi}
+
+
+# Driver for a base channel that emits several short "files"
+# with each terminated by a fleeting EOF
+ 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 {
+ if {![info exists index($chan)]} {return}
+ unset index($chan) buffer($chan)
+ return
+ }
+ watch {}
+ read {
+ set n [lindex $args 1]
+ if {![info exists index($chan)]} {
+ driver initialize $chan
+ }
+ set new [expr {$index($chan) + $n}]
+ set result [string range $buffer($chan) $index($chan) $new-1]
+ set index($chan) $new
+ if {[string length $result] == 0} {
+ driver finalize $chan
+ }
+ return $result
+ }
+ }
+ }
+
+test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
+ set chan [chan create read [namespace which driver]]
+ identity -attach $chan
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+proc delay {op data} {
+ variable store
+ switch -- $op {
+ create/write - create/read -
+ delete/write - delete/read -
+ flush/write - write -
+ clear_read {;#ignore}
+ flush/read -
+ read {
+ if {![info exists store]} {set store {}}
+ set reply $store
+ set store $data
+ return $reply
+ }
+ query/maxRead {return -1}
+ }
+}
+
+test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
+ set chan [chan create read [namespace which driver]]
+ testchannel transform $chan -command [namespace code delay]
+ list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
+ [read $chan] [eof $chan]
+} -cleanup {
+ close $chan
+} -result {0 ..... 1 {} 0 ..... 1}
+
+rename delay {}
+rename driver {}
+
+# cleanup
+foreach file [list dummy dummyout __echo_srv__.tcl] {
+ removeFile $file
+}
+cleanupTests
+}
+namespace delete ::tcl::test::iogt
+return
generated by cgit v0.12 at 2024-09-03 05:54:08 (GMT)