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, 172 insertions, 305 deletions
diff --git a/tests/iogt.test b/tests/iogt.test
index 20d7538..33a6425 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,6 +14,10 @@ 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::*
@@ -36,41 +40,38 @@ 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
- variable c$c
+ incr c
+ namespace upvar [namespace current] c$c conn
#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
- variable c$c
- upvar 0 c$c conn
+ 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
@@ -84,8 +85,7 @@ proc echoPut {c sock} {
variable idelay
variable fdelay
variable bsizes
- variable c$c
- upvar 0 c$c conn
+ namespace upvar [namespace current] c$c conn
if {[string length $conn(data)] == 0} {
#puts stdout "C $c $sock" ; flush stdout
@@ -96,9 +96,7 @@ proc echoPut {c sock} {
return
}
-
set conn(delay) $idelay
-
set n [lindex $bsizes $conn(size)]
#puts stdout "P $c $sock $n >>" ; flush stdout
@@ -107,7 +105,6 @@ 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]
@@ -128,40 +125,33 @@ 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.
+ # 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
+ upvar 1 sock sk
- exec tclsh __echo_srv__.tcl \
- $port $fdelay $idelay {*}$blocks >@stdout &
+ # 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 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]
+ #puts stdout ">>>>>"; flush stdout
+ set res [uplevel 1 $script]
catch {close $sk}
return $res
}
@@ -171,18 +161,15 @@ 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
+ }
}
}
@@ -191,43 +178,34 @@ 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} {
- variable $var
- upvar 0 $var trail
+ 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 {
+ 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 {
@@ -273,18 +251,19 @@ proc id_torture {chan op data} {
}
proc counter {var op data} {
- variable $var
- upvar 0 $var n
+ namespace upvar [namespace current] $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} {
@@ -299,25 +278,20 @@ proc counter {var op data} {
}
}
-
proc counter_audit {var vtrail op data} {
- variable $var
- variable $vtrail
- upvar 0 $var n $vtrail trail
+ namespace upvar [namespace current] $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} {
@@ -335,36 +309,28 @@ proc counter_audit {var vtrail op data} {
return $res
}
-
proc rblocks {var vtrail n op data} {
- variable $var
- variable $vtrail
- upvar 0 $var buf $vtrail trail
+ namespace upvar [namespace current] $var n $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
@@ -378,18 +344,15 @@ 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]]
}
@@ -399,19 +362,15 @@ proc torture {-attach channel} {
}
proc stopafter {var n -attach channel} {
- variable $var
- upvar 0 $var vn
+ 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} {
- variable $var
- upvar 0 $var vn
+ 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]]
}
@@ -421,36 +380,31 @@ 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]]
@@ -459,79 +413,53 @@ 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} testchannel {
+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
+ 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] \
- ]
-
+ list [string equal $ca $cc] [fconfigure $fh -buffering] \
+ [fconfigure $fh -translation] [fconfigure $fh -encoding]
+} -cleanup {
close $fh
- set res
-} {0 line cr shiftjis}
+} -result {0 line cr shiftjis}
-test iogt-2.0 {basic I/O going through transform} testchannel {
- set fin [open $path(dummy) r]
+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 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]
-
+ list [string equal [set in [read $fin]] [set out [read $fout]]] \
+ [string length $in] [string length $out]
+} -cleanup {
close $fin
close $fout
-
- set res
-} {1 71 71}
-
-
+} -result {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
@@ -565,23 +493,17 @@ 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
@@ -619,24 +541,17 @@ 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*
@@ -685,109 +600,80 @@ test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
close $fh
} {}
-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
+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.
-
- proc DoneCopy {n {err {}}} {
- variable copy ; set copy 1
- }
-
- set fin [open $path(dummy) r]
-
+ 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
-} {1 {create/write create/read write flush/write flush/read delete/write delete/read}}
-
+} -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} {testchannel unknownFailure} {
- set fin [open $path(dummy) r]
+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]
-
+ set got [list]
proc Done {args} {
- variable stop
- set stop 1
+ 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 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 [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.
-
+ 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
-
-
- rename Done {}
- rename Get {}
-
join [list [join $got \n] ~~~~~~~~ [join $trail \n]] \n
-} {[[]]
+} -cleanup {
+ rename Done {}
+} -result {[[]]
[[abcdefghijklmnopqrstuvw]]
[[xyz0123456789,./?><;'\|]]
[[]]
@@ -868,35 +754,27 @@ 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} {testchannel unknownFailure} {
- set fin [open $path(dummy) r]
+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
+ 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
-} {create/read {} *ignored*
+} -result {create/read {} *ignored*
counter:create/read {} {}
create/write {} *ignored*
counter:query/maxRead {} 20
@@ -930,44 +808,37 @@ 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} testchannel {
+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"
-
+ 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.
-
- set res [read $f 3]
+ # 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
- set res
-} {xxx}
-
-test iogt-6.1 {Push back and up} {testchannel knownBug} {
+} -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
@@ -978,20 +849,16 @@ test iogt-6.1 {Push back and up} {testchannel knownBug} {
# to 1, but who wants to do that?
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
- set res
-} {xxxghi}
-
-
+} -result {xxxghi}
+
# cleanup
foreach file [list dummy dummyout __echo_srv__.tcl] {
removeFile $file
generated by cgit v0.12 at 2024-11-26 11:46:42 (GMT)