diff options
Diffstat (limited to 'tests')
-rw-r--r-- | tests/pid.test | 7 | ||||
-rw-r--r-- | tests/socket.test | 101 | ||||
-rw-r--r-- | tests/winPipe.test | 101 |
3 files changed, 109 insertions, 100 deletions
diff --git a/tests/pid.test b/tests/pid.test index cbf24ac..8d89235 100644 --- a/tests/pid.test +++ b/tests/pid.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: pid.test,v 1.6 2000/04/10 17:19:03 ericm Exp $ +# RCS: @(#) $Id: pid.test,v 1.7 2002/07/04 20:06:13 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -27,12 +27,13 @@ if {[info commands pid] == ""} { } catch {removeFile test1} +set path(test1) [makeFile {} test1] test pid-1.1 {pid command} { regexp {(^[0-9]+$)|(^0x[0-9a-fA-F]+$)} [pid] } 1 test pid-1.2 {pid command} {unixOrPc unixExecs} { - set f [open {| echo foo | cat >test1} w] + set f [open [format {| echo foo | cat >%s} $path(test1)] w] set pids [pid $f] close $f catch {removeFile test1} @@ -41,7 +42,7 @@ test pid-1.2 {pid command} {unixOrPc unixExecs} { [expr {[lindex $pids 0] == [lindex $pids 1]}] } {2 1 1 0} test pid-1.3 {pid command} { - set f [open test1 w] + set f [open $path(test1) w] set pids [pid $f] close $f set pids diff --git a/tests/socket.test b/tests/socket.test index f5c75b1..172a46b 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: socket.test,v 1.23 2002/04/15 23:09:12 dgp Exp $ +# RCS: @(#) $Id: socket.test,v 1.24 2002/07/04 20:06:13 andreas_kupries Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -248,9 +248,11 @@ test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} +set path(script) [makeFile {} script] + test socket-2.1 {tcp connection} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timed_out"] set f [socket -server accept 0] @@ -267,7 +269,7 @@ test socket-2.1 {tcp connection} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket 127.0.0.1 $listen} msg]} { @@ -288,7 +290,7 @@ if [info exists port] { } test socket-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -305,7 +307,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen global port @@ -324,7 +326,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} { } [list ready "hello $port"] test socket-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] set f [socket -server accept 2830] @@ -340,7 +342,7 @@ test socket-2.3 {tcp connection with client interface specified} {socket stdio} close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} { set x $sock @@ -355,7 +357,7 @@ test socket-2.3 {tcp connection with client interface specified} {socket stdio} } {ready {hello 127.0.0.1}} test socket-2.4 {tcp connection with server interface specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] set f [socket -server accept -myaddr [info hostname] 0] @@ -372,7 +374,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio} close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket [info hostname] $listen} sock]} { @@ -388,7 +390,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio} } {ready hello} test socket-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -405,7 +407,7 @@ test socket-2.5 {tcp connection with redundant server port} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket 127.0.0.1 $listen} sock]} { @@ -431,7 +433,7 @@ test socket-2.6 {tcp connection} {socket} { } ok test socket-2.7 {echo server, one line} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -457,7 +459,7 @@ test socket-2.7 {echo server, one line} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -498,7 +500,7 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { close $f puts "done $i" } script - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -517,10 +519,10 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { test socket-2.9 {socket conflict} {socket stdio} { set s [socket -server accept 0] removeFile script - set f [open script w] + set f [open $path(script) w] puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f after 100 set x [list [catch {close $f} msg]] @@ -583,7 +585,7 @@ test socket-2.11 {detecting new data} {socket} { test socket-3.1 {socket conflict} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set f [socket -server accept 0] puts ready @@ -592,7 +594,7 @@ test socket-3.1 {socket conflict} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] gets $f gets $f listen set x [list [catch {socket -server accept $listen} msg] \ @@ -603,7 +605,7 @@ test socket-3.1 {socket conflict} {socket stdio} { } {1 {couldn't open socket: address already in use}} test socket-3.2 {server with several clients} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] @@ -636,7 +638,7 @@ test socket-3.2 {server with several clients} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] set x [gets $f] gets $f listen set s1 [socket 127.0.0.1 $listen] @@ -663,7 +665,7 @@ test socket-3.2 {server with several clients} {socket stdio} { test socket-4.1 {server with several clients} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set port [gets stdin] set s [socket 127.0.0.1 $port] @@ -677,11 +679,11 @@ test socket-4.1 {server with several clients} {socket stdio} { gets stdin } close $f - set p1 [open "|[list $::tcltest::tcltest script]" r+] + set p1 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p1 -buffering line - set p2 [open "|[list $::tcltest::tcltest script]" r+] + set p2 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p2 -buffering line - set p3 [open "|[list $::tcltest::tcltest script]" r+] + set p3 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p3 -buffering line proc accept {s a p} { fconfigure $s -buffering line @@ -763,13 +765,13 @@ test socket-5.3 {byte order problems, socket numbers, htons} \ test socket-6.1 {accept callback error} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { gets stdin port socket 127.0.0.1 $port } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] proc bgerror args { global x set x $args @@ -788,7 +790,7 @@ test socket-6.1 {accept callback error} {socket stdio} { test socket-7.1 {testing socket specific options} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set ss [socket -server accept 0] proc accept args { @@ -802,7 +804,7 @@ test socket-7.1 {testing socket specific options} {socket stdio} { after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -816,7 +818,7 @@ test socket-7.1 {testing socket specific options} {socket stdio} { } {0 0 3} test socket-7.2 {testing socket specific options} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set ss [socket -server accept 2821] proc accept args { @@ -830,7 +832,7 @@ test socket-7.2 {testing socket specific options} {socket stdio} { after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -1390,6 +1392,9 @@ test socket-11.13 {testing async write, async flush, async close} \ set count } 65566 +set path(script1) [makeFile {} script1] +set path(script2) [makeFile {} script2] + test socket-12.1 {testing inheritance of server sockets} {socket exec} { removeFile script1 removeFile script2 @@ -1397,7 +1402,7 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} { # Script1 is just a 10 second delay. If the server socket # is inherited, it will be held open for 10 seconds - set f [open script1 w] + set f [open $path(script1) w] puts $f { after 10000 exit vwait forever @@ -1408,25 +1413,25 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} { # waits a second, and exits. The server socket will now # be closed unless script1 inherited it. - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { set f [socket -server accept 0] puts [lindex [fconfigure $f -sockname] 2] proc accept { file addr port } { close $file } - exec $tcltest script1 & + exec $tcltest "%s" & close $f after 1000 exit vwait forever - } + } $path(script1)] close $f # Launch script2 and wait 5 seconds ### exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" r] + set p [open "|[list $::tcltest::tcltest $path(script2)]" r] gets $p listen after 5000 { set ok_to_proceed 1 } @@ -1453,7 +1458,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # Script1 is just a 20 second delay. If the server socket # is inherited, it will be held open for 10 seconds - set f [open script1 w] + set f [open $path(script1) w] puts $f { after 20000 exit vwait forever @@ -1464,17 +1469,17 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # launches script1 and exits. If the child process inherited the # client socket, the socket will still be open. - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { gets stdin port set f [socket 127.0.0.1 $port] - exec $tcltest script1 & + exec $tcltest "%s" & puts $f testing flush $f after 1000 exit vwait forever - } + } $path(script1)] close $f # Create the server socket @@ -1521,7 +1526,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # Launch the script2 process ### exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" w] + set p [open "|[list $::tcltest::tcltest $path(script2)]" w] puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p vwait x @@ -1537,33 +1542,33 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket exec} { removeFile script1 removeFile script2 - set f [open script1 w] + set f [open $path(script1) w] puts $f { after 10000 exit vwait forever } close $f - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { set server [socket -server accept 0] puts stdout [lindex [fconfigure $server -sockname] 2] proc accept { file host port } { global tcltest puts $file {test data on socket} - exec $tcltest script1 & + exec $tcltest "%s" & after 1000 exit } vwait forever - } + } $path(script1)] close $f # Launch the script2 process and connect to it. See how long # the socket stays open ## exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" r] + set p [open "|[list $::tcltest::tcltest $path(script2)]" r] gets $p listen after 1000 set ok_to_proceed 1 diff --git a/tests/winPipe.test b/tests/winPipe.test index a445793..3e99625 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winPipe.test,v 1.16 2002/05/24 22:43:31 andreas_kupries Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.17 2002/07/04 20:06:13 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -38,11 +38,13 @@ append big $big append big $big append big $big -set f [open "little" w] +set path(little) [makeFile {} little] +set f [open $path(little) w] puts -nonewline $f "little" close $f -set f [open "big" w] +set path(big) [makeFile {} big] +set f [open $path(big) w] puts -nonewline $f $big close $f @@ -53,83 +55,84 @@ proc contents {file} { set r } -set f [open more w] -puts $f { +set path(more) [makeFile { while {[eof stdin] == 0} { puts -nonewline [read stdin] } -} -close $f +} more] + +set path(stdout) [makeFile {} stdout] +set path(stderr) [makeFile {} stderr] test winpipe-1.1 {32 bit comprehensive tests: from little file} {pcOnly stdio cat32} { - exec $cat32 < little > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.2 {32 bit comprehensive tests: from big file} {pcOnly stdio cat32} { - exec $cat32 < big > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.3 {32 bit comprehensive tests: a little from pipe} {nt stdio cat32} { - exec $::tcltest::tcltest more < little | $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $::tcltest::tcltest more < little | $cat32 > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.4 {32 bit comprehensive tests: a lot from pipe} {nt stdio cat32} { - exec $::tcltest::tcltest more < big | $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $::tcltest::tcltest more < big | $cat32 > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.5 {32 bit comprehensive tests: a lot from pipe} {95 stdio cat32} { - exec command /c type big |& $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] + exec command /c type big |& $cat32 > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.6 {32 bit comprehensive tests: from console} \ {pcOnly stdio cat32 AllocConsole} { # would block waiting for human input } {} test winpipe-1.7 {32 bit comprehensive tests: from NUL} {pcOnly stdio cat32} { - exec $cat32 < nul > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < nul > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {{} stderr32} test winpipe-1.8 {32 bit comprehensive tests: from socket} {pcOnly stdio cat32} { # doesn't work } {} test winpipe-1.9 {32 bit comprehensive tests: from nowhere} \ {pcOnly stdio cat32 .console} { - exec $cat32 > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {{} stderr32} test winpipe-1.10 {32 bit comprehensive tests: from file handle} \ {pcOnly stdio cat32} { - set f [open "little" r] - exec $cat32 <@$f > stdout 2> stderr + set f [open $path(little) r] + exec $cat32 <@$f > $path(stdout) 2> $path(stderr) close $f - list [contents stdout] [contents stderr] + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.11 {32 bit comprehensive tests: read from application} \ {pcOnly stdio cat32} { - set f [open "|[list $cat32] < little" r] + set f [open "|[list $cat32] < $path(little)" r] gets $f line catch {close $f} msg list $line $msg } {little stderr32} test winpipe-1.12 {32 bit comprehensive tests: a little to file} \ {pcOnly stdio cat32} { - exec $cat32 < little > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(little) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.13 {32 bit comprehensive tests: a lot to file} \ {pcOnly stdio cat32} { - exec $cat32 < big > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(big) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.14 {32 bit comprehensive tests: a little to pipe} \ {pcOnly stdio cat32} { - exec $cat32 < little | $::tcltest::tcltest more > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(little) | $::tcltest::tcltest $path(more) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.15 {32 bit comprehensive tests: a lot to pipe} \ {pcOnly stdio cat32} { - exec $cat32 < big | $::tcltest::tcltest more > stdout 2> stderr - list [contents stdout] [contents stderr] + exec $cat32 < $path(big) | $::tcltest::tcltest $path(more) > $path(stdout) 2> $path(stderr) + list [contents $path(stdout)] [contents $path(stderr)] } "{$big} stderr32" test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly stdio cat32} { catch {exec $cat32 << "You should see this\n" >@stdout} msg @@ -137,27 +140,27 @@ test winpipe-1.16 {32 bit comprehensive tests: to console} {pcOnly stdio cat32} } stderr32 test winpipe-1.17 {32 bit comprehensive tests: to NUL} {pcOnly stdio cat32} { # some apps hang when sending a large amount to NUL. $cat32 isn't one. - catch {exec $cat32 < big > nul} msg + catch {exec $cat32 < $path(big) > nul} msg set msg } stderr32 test winpipe-1.18 {32 bit comprehensive tests: to nowhere} \ {pcOnly stdio cat32 .console} { - exec $cat32 < big >&@stdout + exec $cat32 < $path(big) >&@stdout } {} test winpipe-1.19 {32 bit comprehensive tests: to file handle} {pcOnly stdio cat32} { - set f1 [open "stdout" w] - set f2 [open "stderr" w] - exec $cat32 < little >@$f1 2>@$f2 + set f1 [open $path(stdout) w] + set f2 [open $path(stderr) w] + exec $cat32 < $path(little) >@$f1 2>@$f2 close $f1 close $f2 - list [contents stdout] [contents stderr] + list [contents $path(stdout)] [contents $path(stderr)] } {little stderr32} test winpipe-1.20 {32 bit comprehensive tests: write to application} \ {pcOnly stdio cat32} { - set f [open |[list $cat32 >stdout] w] + set f [open |[list $cat32 >$path(stdout)] w] puts -nonewline $f "foo" catch {close $f} msg - list [contents stdout] $msg + list [contents $path(stdout)] $msg } {foo stderr32} test winpipe-1.21 {32 bit comprehensive tests: read/write application} \ {pcOnly stdio cat32} { @@ -187,13 +190,13 @@ test winpipe-4.1 {Tcl_WaitPid} {nt stdio cat32} { } } - set f [open "|[list $cat32] < big 2> stderr" r] + set f [open "|[list $cat32] < big 2> $path(stderr)" r] fconfigure $f -buffering none -blocking 0 fileevent $f readable "readResults $f" set x 0 set result "" vwait x - list $result $x [contents stderr] + list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" close [open nothing w] @@ -279,16 +282,16 @@ test winpipe-6.2 {PipeSetupProc & PipeCheckProc: write threads} \ lappend x [catch {close $f} msg] $msg } {writable timeout 0 {}} -makeFile { +set path(echoArgs.tcl) [makeFile { puts "[list $argv0 $argv]" -} echoArgs.tcl +} echoArgs.tcl] test winpipe-7.1 {BuildCommandLine: null arguments} {pcOnly stdio} { - exec $::tcltest::tcltest echoArgs.tcl foo "" bar -} {echoArgs.tcl {foo {} bar}} + exec $::tcltest::tcltest $path(echoArgs.tcl) foo "" bar +} [list $path(echoArgs.tcl) {foo {} bar}] test winpipe-7.2 {BuildCommandLine: null arguments} {pcOnly stdio} { - exec $::tcltest::tcltest echoArgs.tcl foo \" bar -} {echoArgs.tcl {foo {"} bar}} + exec $::tcltest::tcltest $path(echoArgs.tcl) foo \" bar +} [list $path(echoArgs.tcl) {foo {"} bar}] # restore old values for env(TMP) and env(TEMP) |