summaryrefslogtreecommitdiffstats
path: root/tests/iogt.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/iogt.test')
-rw-r--r--tests/iogt.test477
1 files changed, 305 insertions, 172 deletions
diff --git a/tests/iogt.test b/tests/iogt.test
index ded8bb9..d81acd6 100644
--- a/tests/iogt.test
+++ b/tests/iogt.test
@@ -3,8 +3,8 @@
#
# 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.
+# 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.
@@ -14,10 +14,6 @@ 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::*
@@ -40,38 +36,41 @@ set path(__echo_srv__.tcl) [makeFile {
# delay between blocks
# blocksize ...
-set port [lindex $argv 0]
+set port [lindex $argv 0]
set fdelay [lindex $argv 1]
set idelay [lindex $argv 2]
set bsizes [lrange $argv 3 end]
-set c 0
+set c 0
proc newconn {sock rhost rport} {
variable fdelay
variable c
- incr c
- namespace upvar [namespace current] c$c conn
+ 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(size) 0
+ set conn(data) ""
set conn(delay) $fdelay
- fileevent $sock readable [list echoGet $c $sock]
+ 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
+ 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
@@ -85,7 +84,8 @@ proc echoPut {c sock} {
variable idelay
variable fdelay
variable bsizes
- namespace upvar [namespace current] c$c conn
+ variable c$c
+ upvar 0 c$c conn
if {[string length $conn(data)] == 0} {
#puts stdout "C $c $sock" ; flush stdout
@@ -96,7 +96,9 @@ proc echoPut {c sock} {
return
}
+
set conn(delay) $idelay
+
set n [lindex $bsizes $conn(size)]
#puts stdout "P $c $sock $n >>" ; flush stdout
@@ -105,6 +107,7 @@ proc echoPut {c sock} {
#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]
@@ -125,33 +128,40 @@ 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
+ # 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.
+ # 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 &
+ exec tclsh __echo_srv__.tcl \
+ $port $fdelay $idelay {*}$blocks >@stdout &
+
after 500
- #puts stdout "> $port"; flush stdout
+ #puts stdout "> $port" ; flush stdout
+
+ set sk [socket localhost $port]
+ fconfigure $sk \
+ -blocking 0 \
+ -buffering full \
+ -buffersize [expr {10+[llength $data]}]
- 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
+ #puts stdout ">>>>>" ; flush stdout
+
+ uplevel #0 set sock $sk
+ set res [uplevel #0 $script]
- set res [uplevel 1 $script]
catch {close $sk}
return $res
}
@@ -161,15 +171,18 @@ proc fevent {fdelay idelay blocks script data} {
proc id {op data} {
switch -- $op {
- create/write - create/read - delete/write - delete/read - clear_read {
- #ignore
- }
- flush/write - flush/read - write - read {
+ create/write -
+ create/read -
+ delete/write -
+ delete/read -
+ clear_read {;#ignore}
+ flush/write -
+ flush/read -
+ write -
+ read {
return $data
}
- query/maxRead {
- return -1
- }
+ query/maxRead {return -1}
}
}
@@ -178,34 +191,43 @@ proc id_optrail {var op data} {
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 {
+ create/write - create/read -
+ delete/write - delete/read -
+ flush/read -
+ clear/read { #ignore }
+ flush/write -
+ write -
+ read {
return $data
}
- query/maxRead {
+ query/maxRead {
return -1
}
- default {
+ default {
lappend trail "error $op"
error $op
}
}
}
+
proc id_fulltrail {var op data} {
- namespace upvar [namespace current] $var trail
+ 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 {
+ create/write - create/read -
+ delete/write - delete/read -
+ clear_read {
set res *ignored*
}
- flush/write - flush/read - write - read {
+ flush/write - flush/read -
+ write -
+ read {
set res $data
}
query/maxRead {
@@ -241,19 +263,18 @@ proc id_torture {chan op data} {
}
proc counter {var op data} {
- namespace upvar [namespace current] $var n
+ variable $var
+ upvar 0 $var n
switch -- $op {
- create/write - create/read - delete/write - delete/read - clear_read {
- #ignore
- }
- flush/write - flush/read {
- return {}
- }
+ create/write - create/read -
+ delete/write - delete/read -
+ clear_read {;#ignore}
+ flush/write - flush/read {return {}}
write {
return $data
}
- read {
+ read {
if {$n > 0} {
incr n -[string length $data]
if {$n < 0} {
@@ -268,20 +289,25 @@ proc counter {var op data} {
}
}
+
proc counter_audit {var vtrail op data} {
- namespace upvar [namespace current] $var n $vtrail trail
+ variable $var
+ variable $vtrail
+ upvar 0 $var n $vtrail trail
switch -- $op {
- create/write - create/read - delete/write - delete/read - clear_read {
+ create/write - create/read -
+ delete/write - delete/read -
+ clear_read {
set res {}
}
- flush/write - flush/read {
+ flush/write - flush/read {
set res {}
}
write {
set res $data
}
- read {
+ read {
if {$n > 0} {
incr n -[string length $data]
if {$n < 0} {
@@ -299,28 +325,36 @@ proc counter_audit {var vtrail op data} {
return $res
}
+
proc rblocks {var vtrail n op data} {
- namespace upvar [namespace current] $var n $vtrail trail
+ variable $var
+ variable $vtrail
+ upvar 0 $var buf $vtrail trail
set res {}
switch -- $op {
- create/write - create/read - delete/write - delete/read - clear_read {
+ create/write - create/read -
+ delete/write - delete/read -
+ clear_read {
set buf {}
}
flush/write {
}
- flush/read {
+ flush/read {
set res $buf
set buf {}
}
- write {
+ write {
set data
}
- read {
+ 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
@@ -334,15 +368,18 @@ proc rblocks {var vtrail n op data} {
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]]
}
@@ -352,15 +389,19 @@ proc torture {-attach channel} {
}
proc stopafter {var n -attach channel} {
- namespace upvar [namespace current] $var vn
+ 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} {
- namespace upvar [namespace current] $var vn
+ 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]]
}
@@ -370,31 +411,36 @@ proc rblocks_t {var trail n -attach channel} {
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 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
+ close $fh
} {}
+
test iogt-1.2 {stack/close} testchannel {
set fh [open $path(dummy) r]
identity -attach $fh
- close $fh
+ close $fh
} {}
+
test iogt-1.3 {stack/unstack, configuration, options} testchannel {
set fh [open $path(dummy) r]
set ca [asort [fconfigure $fh]]
@@ -403,53 +449,79 @@ test iogt-1.3 {stack/unstack, configuration, options} testchannel {
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.
+
+ # 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 {
+
+test iogt-1.4 {stack/unstack, configuration} testchannel {
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
+ 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 {
+
+ set res [list \
+ [string equal $ca $cc] \
+ [fconfigure $fh -buffering] \
+ [fconfigure $fh -translation] \
+ [fconfigure $fh -encoding] \
+ ]
+
close $fh
-} -result {0 line cr shiftjis}
+ set res
+} {0 line cr shiftjis}
-test iogt-2.0 {basic I/O going through transform} -setup {
- set fin [open $path(dummy) r]
+test iogt-2.0 {basic I/O going through transform} testchannel {
+ 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 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 {
+
+ set res [string equal [set in [read $fin]] [set out [read $fout]]]
+ lappend res [string length $in] [string length $out]
+
close $fin
close $fout
-} -result {1 71 71}
+
+ set res
+} {1 71 71}
+
+
test iogt-2.1 {basic I/O, operation trail} {testchannel unix} {
- set fin [open $path(dummy) r]
+ set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
- set ain [list]; set aout [list]
- audit_ops ain -attach $fin
+
+ set ain [list] ; set aout [list]
+ audit_ops ain -attach $fin
audit_ops aout -attach $fout
- fconfigure $fin -buffersize 10
+
+ 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
@@ -483,17 +555,23 @@ write
write
flush/write
delete/write}
+
test iogt-2.2 {basic I/O, data trail} {testchannel unix} {
- set fin [open $path(dummy) r]
+ set fin [open $path(dummy) r]
set fout [open $path(dummyout) w]
- set ain [list]; set aout [list]
- audit_flow ain -attach $fin
+
+ set ain [list] ; set aout [list]
+ audit_flow ain -attach $fin
audit_flow aout -attach $fout
- fconfigure $fin -buffersize 10
+
+ 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
@@ -531,17 +609,24 @@ write {
}
flush/write {} {}
delete/write {} *ignored*}
+
+
test iogt-2.3 {basic I/O, mixed trail} {testchannel unix} {
- set fin [open $path(dummy) r]
+ 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 $fin -buffersize 20
fconfigure $fout -buffersize 10
+
fcopy $fin $fout
+
close $fin
close $fout
+
join $trail \n
} {create/read {} *ignored*
create/write {} *ignored*
@@ -581,80 +666,109 @@ test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
set x
} {}
-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
+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.
- set fin [open $path(dummy) r]
+
+ 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.
+
+ 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.
+
+ # 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]; # {}
+ } [read $fin] ; # {}
+
close $fout
+
+ rename DoneCopy {}
+
# Check result of copy.
- set fin [open $path(dummy) r]
+
+ 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}}
+} {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]
+
+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]
+ set got [list]
+
proc Done {args} {
- variable stop 1
+ variable stop
+ set stop 1
}
-} -constraints {testchannel hangs} -body {
+
+ 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 [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.
+ 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
- join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
-} -cleanup {
+
+
rename Done {}
-} -result {[[]]
+ rename Get {}
+
+ join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
+} {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
[[]]
@@ -735,27 +849,35 @@ rblock | delete/write {} {} | {}
rblock | delete/read {} {} | {}
flush/write {} {}
delete/write {} *ignored*
-delete/read {} *ignored*}; # catch unescaped quote "
+delete/read {} *ignored*} ; # catch unescaped quote "
-test iogt-5.0 {EOF simulation} -setup {
- set fin [open $path(dummy) r]
+
+test iogt-5.0 {EOF simulation} {testchannel unknownFailure} {
+ 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
+ stopafter_audit d trail 20 -attach $fin
audit_flow trail -attach $fout
- fconfigure $fin -buffersize 20
+
+ fconfigure $fin -buffersize 20
fconfigure $fout -buffersize 10
- fcopy $fin $fout
+
+ 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*
+} {create/read {} *ignored*
counter:create/read {} {}
create/write {} *ignored*
counter:query/maxRead {} 20
@@ -789,48 +911,59 @@ 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 {
+ 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
- }
+ query/maxRead {return -1}
}
}
+
proc constx {-attach channel} {
testchannel transform $channel -command [namespace code constX]
}
-test iogt-6.0 {Push back} -constraints testchannel -body {
+test iogt-6.0 {Push back} testchannel {
set f [open $path(dummy) r]
+
# contents of dummy = "abcdefghi..."
- read $f 3; # skip behind "abc"
+ 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".
+
+ # 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 {
+ # 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
-} -result {xxx}
-test iogt-6.1 {Push back and up} -constraints {testchannel knownBug} -body {
+ 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"
+ 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}
-
+ set res
+} {xxxghi}
+
+
# cleanup
foreach file [list dummy dummyout __echo_srv__.tcl] {
removeFile $file
generated by cgit v0.12 at 2024-11-23 02:42:04 (GMT)