# -*- 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.16 2006/11/03 11:45:34 dkf 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::*
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 -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.
# 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
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 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} \
{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
|
