# -*- 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. # # RCS: @(#) $Id: iogt.test,v 1.1.1.1 2007/07/10 15:04:24 duncan Exp $ 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::cleanupTests namespace import ::tcltest::makeFile namespace import ::tcltest::removeFile namespace import ::tcltest::test namespace import ::tcltest::testConstraint 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 variable c$c #puts stdout "C $sock $rhost $rport / $fdelay" ; flush stdout upvar 0 c$c conn 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 variable c$c upvar 0 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 variable c$c upvar 0 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 $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. # fixed port, not so good. lets hope for the best, for now. set port 4000 eval 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 uplevel #0 set sock $sk set res [uplevel #0 $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} { variable $var upvar 0 $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} { variable $var upvar 0 $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} { variable $var variable $vtrail upvar 0 $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} { variable $var variable $vtrail upvar 0 $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 stopafter {var n -attach channel} { variable $var upvar 0 $var vn set vn $n testchannel transform $channel -command [namespace code [list counter $var]] } proc stopafter_audit {var trail n -attach channel} { variable $var upvar 0 $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} testchannel { set fh [open $path(dummy) r] set ca [asort [fconfigure $fh]] identity -attach $fh fconfigure $fh \ -buffering line \ -translation cr \ -encoding shiftjis testchannel unstack $fh set cc [asort [fconfigure $fh]] set res [list \ [string equal $ca $cc] \ [fconfigure $fh -buffering] \ [fconfigure $fh -translation] \ [fconfigure $fh -encoding] \ ] close $fh set res } {0 line cr shiftjis} test iogt-2.0 {basic I/O going through transform} testchannel { set fin [open $path(dummy) r] set fout [open $path(dummyout) w] 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] set res [string equal [set in [read $fin]] [set out [read $fout]]] lappend res [string length $in] [string length $out] close $fin close $fout set res } {1 71 71} test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} { 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 unixOnly} { 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 unixOnly} { 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} \ {testchannel unknownFailure} { # 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. proc DoneCopy {n {err {}}} { variable copy ; set copy 1 } 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 rename DoneCopy {} # 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 } {1 {create/write create/read write flush/write flush/read delete/write delete/read}} test iogt-4.0 {fileevent readable, after transform} {testchannel unknownFailure} { set fin [open $path(dummy) r] set data [read $fin] close $fin set trail [list] set got [list] proc Done {args} { variable stop set 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 } fevent 1000 500 {20 20 20 10 1} { audit_flow trail -attach $sock rblocks_t rbuf trail 23 -attach $sock fileevent $sock readable [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 rename Done {} rename Get {} join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n } {[[]] [[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} {testchannel unknownFailure} { set fin [open $path(dummy) r] set fout [open $path(dummyout) w] set trail [list] 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 } {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} testchannel { 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. set res [read $f 3] close $f set res } {xxx} test iogt-6.1 {Push back and up} {testchannel knownBug} { 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] close $f set res } {xxxghi} # cleanup foreach file [list dummy dummyout __echo_srv__.tcl] { removeFile $file } cleanupTests } namespace delete ::tcl::test::iogt return