# -*- 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 } 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 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 n $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 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 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 {} {} 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 { } { } delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup { proc DoneCopy {n {err {}}} { variable copy 1 } } -constraints {testchannel hangs} -body { # This test to check the validity of aquired 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} { 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 } } -constraints {testchannel hangs} -body { fevent 1000 500 {20 20 20 10 1} { audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock fileevent $sock readable [namespace code { if {[eof $sock]} { Done lappend trail "xxxxxxxxxxxxx" close $sock } else { lappend trail "vvvvvvvvvvvvv" lappend trail "\tgot: [lappend got "\[\[[read $sock]\]\]"]" lappend trail "=============" #puts stdout $__; flush stdout #read $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 {} } -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 unknownFailure} -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 { 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} # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file } cleanupTests } namespace delete ::tcl::test::iogt return