956 lines
24 KiB
Plaintext
956 lines
24 KiB
Plaintext
|
# -*- 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
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
::tcltest::loadTestedCommands
|
|||
|
|
catch [list package require -exact Tcltest [info patchlevel]]
|
|||
|
|
|
|||
|
|
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 id_torture {chan op data} {
|
|||
|
|
switch -- $op {
|
|||
|
|
create/write -
|
|||
|
|
create/read -
|
|||
|
|
delete/write -
|
|||
|
|
delete/read -
|
|||
|
|
clear_read {;#ignore}
|
|||
|
|
flush/write -
|
|||
|
|
flush/read {}
|
|||
|
|
write {
|
|||
|
|
global level
|
|||
|
|
if {$level} {
|
|||
|
|
return
|
|||
|
|
}
|
|||
|
|
incr level
|
|||
|
|
testchannel unstack $chan
|
|||
|
|
testchannel transform $chan \
|
|||
|
|
-command [namespace code [list id_torture $chan]]
|
|||
|
|
return $data
|
|||
|
|
}
|
|||
|
|
read {
|
|||
|
|
testchannel unstack $chan
|
|||
|
|
testchannel transform $chan \
|
|||
|
|
-command [namespace code [list id_torture $chan]]
|
|||
|
|
return $data
|
|||
|
|
}
|
|||
|
|
query/maxRead {return -1}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
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 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 torture {-attach channel} {
|
|||
|
|
testchannel transform $channel -command [namespace code [list id_torture $channel]]
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
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
|
|||
|
|
query/maxRead
|
|||
|
|
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 {} {}
|
|||
|
|
query/maxRead {} -1
|
|||
|
|
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 {
|
|||
|
|
} {
|
|||
|
|
}
|
|||
|
|
query/maxRead {} -1
|
|||
|
|
delete/read {} *ignored*
|
|||
|
|
flush/write {} {}
|
|||
|
|
delete/write {} *ignored*}
|
|||
|
|
|
|||
|
|
test iogt-2.4 {basic I/O, mixed trail} {testchannel} {
|
|||
|
|
set fh [open $path(dummy) r]
|
|||
|
|
torture -attach $fh
|
|||
|
|
chan configure $fh -buffersize 2
|
|||
|
|
set x [read $fh]
|
|||
|
|
testchannel unstack $fh
|
|||
|
|
close $fh
|
|||
|
|
set x
|
|||
|
|
} {}
|
|||
|
|
test iogt-2.5 {basic I/O, mixed trail} {testchannel} {
|
|||
|
|
set ::level 0
|
|||
|
|
set fh [open $path(dummyout) w]
|
|||
|
|
torture -attach $fh
|
|||
|
|
puts -nonewline $fh abcdef
|
|||
|
|
flush $fh
|
|||
|
|
testchannel unstack $fh
|
|||
|
|
close $fh
|
|||
|
|
} {}
|
|||
|
|
|
|||
|
|
test iogt-3.0 {Tcl_Channel valid after stack/unstack, fevent handling} -setup {
|
|||
|
|
proc DoneCopy {n {err {}}} {
|
|||
|
|
variable copy 1
|
|||
|
|
}
|
|||
|
|
} -constraints {testchannel knownBug} -body {
|
|||
|
|
# This test to check the validity of acquired 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} {
|
|||
|
|
variable copy
|
|||
|
|
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
|
|||
|
|
}
|
|||
|
|
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 knownBug} -body {
|
|||
|
|
fevent 1000 500 {20 20 20 10 1} {
|
|||
|
|
variable stop
|
|||
|
|
audit_flow trail -attach $sock
|
|||
|
|
rblocks_t rbuf trail 23 -attach $sock
|
|||
|
|
|
|||
|
|
fileevent $sock readable [namespace code [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 {}
|
|||
|
|
rename Get {}
|
|||
|
|
} -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 knownBug} -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 {
|
|||
|
|
|
|||
|
|
# This test demonstrates the bug/misfeature in the stacked
|
|||
|
|
# channel implementation that data can be discarded if it is
|
|||
|
|
# read into the buffers of one channel in the stack, and then
|
|||
|
|
# that channel is popped before anything above it reads.
|
|||
|
|
#
|
|||
|
|
# This bug can be worked around by always setting -buffersize
|
|||
|
|
# to 1, but who wants to do that?
|
|||
|
|
|
|||
|
|
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}
|
|||
|
|
|
|||
|
|
|
|||
|
|
# Driver for a base channel that emits several short "files"
|
|||
|
|
# with each terminated by a fleeting EOF
|
|||
|
|
proc driver {cmd args} {
|
|||
|
|
variable buffer
|
|||
|
|
variable index
|
|||
|
|
set chan [lindex $args 0]
|
|||
|
|
switch -- $cmd {
|
|||
|
|
initialize {
|
|||
|
|
set index($chan) 0
|
|||
|
|
set buffer($chan) .....
|
|||
|
|
return {initialize finalize watch read}
|
|||
|
|
}
|
|||
|
|
finalize {
|
|||
|
|
if {![info exists index($chan)]} {return}
|
|||
|
|
unset index($chan) buffer($chan)
|
|||
|
|
return
|
|||
|
|
}
|
|||
|
|
watch {}
|
|||
|
|
read {
|
|||
|
|
set n [lindex $args 1]
|
|||
|
|
if {![info exists index($chan)]} {
|
|||
|
|
driver initialize $chan
|
|||
|
|
}
|
|||
|
|
set new [expr {$index($chan) + $n}]
|
|||
|
|
set result [string range $buffer($chan) $index($chan) $new-1]
|
|||
|
|
set index($chan) $new
|
|||
|
|
if {[string length $result] == 0} {
|
|||
|
|
driver finalize $chan
|
|||
|
|
}
|
|||
|
|
return $result
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
test iogt-7.0 {Handle fleeting EOF} -constraints {testchannel} -body {
|
|||
|
|
set chan [chan create read [namespace which driver]]
|
|||
|
|
identity -attach $chan
|
|||
|
|
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
|||
|
|
[read $chan] [eof $chan]
|
|||
|
|
} -cleanup {
|
|||
|
|
close $chan
|
|||
|
|
} -result {0 ..... 1 {} 0 ..... 1}
|
|||
|
|
|
|||
|
|
proc delay {op data} {
|
|||
|
|
variable store
|
|||
|
|
switch -- $op {
|
|||
|
|
create/write - create/read -
|
|||
|
|
delete/write - delete/read -
|
|||
|
|
flush/write - write -
|
|||
|
|
clear_read {;#ignore}
|
|||
|
|
flush/read -
|
|||
|
|
read {
|
|||
|
|
if {![info exists store]} {set store {}}
|
|||
|
|
set reply $store
|
|||
|
|
set store $data
|
|||
|
|
return $reply
|
|||
|
|
}
|
|||
|
|
query/maxRead {return -1}
|
|||
|
|
}
|
|||
|
|
}
|
|||
|
|
|
|||
|
|
test iogt-7.1 {Handle fleeting EOF} -constraints {testchannel} -body {
|
|||
|
|
set chan [chan create read [namespace which driver]]
|
|||
|
|
testchannel transform $chan -command [namespace code delay]
|
|||
|
|
list [eof $chan] [read $chan] [eof $chan] [read $chan 0] [eof $chan] \
|
|||
|
|
[read $chan] [eof $chan]
|
|||
|
|
} -cleanup {
|
|||
|
|
close $chan
|
|||
|
|
} -result {0 ..... 1 {} 0 ..... 1}
|
|||
|
|
|
|||
|
|
rename delay {}
|
|||
|
|
rename driver {}
|
|||
|
|
|
|||
|
|
# cleanup
|
|||
|
|
foreach file [list dummy dummyout __echo_srv__.tcl] {
|
|||
|
|
removeFile $file
|
|||
|
|
}
|
|||
|
|
cleanupTests
|
|||
|
|
}
|
|||
|
|
namespace delete ::tcl::test::iogt
|
|||
|
|
return
|