diff options
author | dgp <dgp@users.sourceforge.net> | 2004-02-25 23:38:14 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2004-02-25 23:38:14 (GMT) |
commit | 4e389884a3823483212e4dd7d41287db9cf727ae (patch) | |
tree | 3ebec546b31e48e9389e4c0bc0a55927e5a295e6 | |
parent | c2915400905bc123ad738b9a636d049cd183cae7 (diff) | |
download | tcl-4e389884a3823483212e4dd7d41287db9cf727ae.zip tcl-4e389884a3823483212e4dd7d41287db9cf727ae.tar.gz tcl-4e389884a3823483212e4dd7d41287db9cf727ae.tar.bz2 |
* tests/basic.test: Made several tests more robust to the
* tests/cmdMZ.test: list-quoting of path names that might
* tests/exec.test: contain Tcl-special chars like { or [.
* tests/io.test: Should help us sort out Tcl Bug 554068.
* tests/pid.test:
* tests/socket.test:
* tests/source.test:
* tests/unixInit.test:
-rw-r--r-- | ChangeLog | 11 | ||||
-rw-r--r-- | tests/basic.test | 60 | ||||
-rw-r--r-- | tests/cmdMZ.test | 27 | ||||
-rw-r--r-- | tests/exec.test | 17 | ||||
-rw-r--r-- | tests/io.test | 90 | ||||
-rw-r--r-- | tests/pid.test | 4 | ||||
-rw-r--r-- | tests/socket.test | 32 | ||||
-rw-r--r-- | tests/source.test | 23 | ||||
-rw-r--r-- | tests/unixInit.test | 8 |
9 files changed, 170 insertions, 102 deletions
@@ -1,3 +1,14 @@ +2004-02-25 Don Porter <dgp@users.sourceforge.net> + + * tests/basic.test: Made several tests more robust to the + * tests/cmdMZ.test: list-quoting of path names that might + * tests/exec.test: contain Tcl-special chars like { or [. + * tests/io.test: Should help us sort out Tcl Bug 554068. + * tests/pid.test: + * tests/socket.test: + * tests/source.test: + * tests/unixInit.test: + 2004-02-25 Donal K. Fellows <donal.k.fellows@man.ac.uk> * unix/tclUnixChan.c (TcpGetOptionProc): Stop memory leak with diff --git a/tests/basic.test b/tests/basic.test index 11b7bed..c86111c 100644 --- a/tests/basic.test +++ b/tests/basic.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: basic.test,v 1.25.2.1 2003/05/05 16:52:33 dkf Exp $ +# RCS: @(#) $Id: basic.test,v 1.25.2.2 2004/02/25 23:38:15 dgp Exp $ # package require tcltest 2 @@ -580,63 +580,71 @@ test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} { DONE }} -test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} { +test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { puts hello break } BREAKtest] - set res [list [catch {exec [interpreter] $fName} msg] $msg] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { removeFile BREAKtest - regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res - set res -} {1 {hello +} -returnCodes error -match glob -result {hello invoked "break" outside of a loop while executing "break" - (file "BREAKtest" line 3)}} + (file "*BREAKtest" line 3)} -test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} { +test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { interp alias {} patch {} info patchlevel patch break } BREAKtest] - set res [list [catch {exec [interpreter] $fName} msg] $msg] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { removeFile BREAKtest - regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res - set res -} {1 {invoked "break" outside of a loop +} -returnCodes error -match glob -result {invoked "break" outside of a loop while executing "break" - (file "BREAKtest" line 4)}} + (file "*BREAKtest" line 4)} -test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} { +test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { foo [set a 1] [break] } BREAKtest] - set res [list [catch {exec [interpreter] $fName} msg] $msg] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { removeFile BREAKtest - regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res - set res -} {1 {invoked "break" outside of a loop +} -returnCodes error -match glob -result {invoked "break" outside of a loop while executing "break" invoked from within -"foo [set a 1] [break]" - (file "BREAKtest" line 2)}} +"foo \[set a 1] \[break]" + (file "*BREAKtest" line 2)} -test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} { +test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} -setup { set fName [makeFile { return -code return } BREAKtest] - set res [list [catch {exec [interpreter] $fName} msg] $msg] +} -constraints { + exec +} -body { + exec [interpreter] $fName +} -cleanup { removeFile BREAKtest - regsub {file ".*BREAKtest"} $res {file "BREAKtest"} res - set res -} {1 {command returned bad code: 2 +} -returnCodes error -match glob -result {command returned bad code: 2 while executing "return -code return" - (file "BREAKtest" line 2)}} + (file "*BREAKtest" line 2)} test basic-47.1 {Tcl_EvalEx: check for missing close-bracket} -body { subst {a[set b [format cd]} diff --git a/tests/cmdMZ.test b/tests/cmdMZ.test index 8835764..1e9a58a 100644 --- a/tests/cmdMZ.test +++ b/tests/cmdMZ.test @@ -11,10 +11,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdMZ.test,v 1.13.2.2 2003/11/12 17:29:10 hobbs Exp $ +# RCS: @(#) $Id: cmdMZ.test,v 1.13.2.3 2004/02/25 23:38:16 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -84,16 +84,31 @@ test cmdMZ-3.3 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} {unixOrPc} { list [catch {source a b} msg] $msg } {1 {wrong # args: should be "source fileName"}} -test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body { + +proc ListGlobMatch {expected actual} { + if {[llength $expected] != [llength $actual]} { + return 0 + } + foreach e $expected a $actual { + if {![string match $e $a]} { + return 0 + } + } + return 1 +} +customMatch listGlob ListGlobMatch + +test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -setup { set file [makeFile { set x 146 error "error in sourced file" set y $x } source.file] - set result [list [catch {source $file} msg] $msg $errorInfo] +} -body { + list [catch {source $file} msg] $msg $errorInfo +} -cleanup { removeFile source.file - set result -} -match glob -result {1 {error in sourced file} {error in sourced file +} -match listGlob -result {1 {error in sourced file} {error in sourced file while executing "error "error in sourced file"" (file "*" line 3) diff --git a/tests/exec.test b/tests/exec.test index c5223aa..2da0b7e 100644 --- a/tests/exec.test +++ b/tests/exec.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: exec.test,v 1.16.2.1 2003/10/07 18:53:23 dgp Exp $ +# RCS: @(#) $Id: exec.test,v 1.16.2.2 2004/02/25 23:38:16 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -420,7 +420,7 @@ test exec-11.4 {commands in background} {exec stdio} { } 3 test exec-11.5 {commands in background} {exec} { set f [open $path(gorp.file) w] - puts $f [format { catch { exec [info nameofexecutable] {%s} foo & } } $path(echo)] + puts $f [list catch [list exec [info nameofexecutable] $path(echo) foo &]] close $f string compare "foo" [exec [interpreter] $path(gorp.file)] } 0 @@ -567,12 +567,13 @@ set path(script) [makeFile {} script] test exec-17.1 { inheriting standard I/O } {exec} { set f [open $path(script) w] - puts $f [format {close stdout - set f [open {%s} w] - catch {exec [info nameofexecutable] {%s} foobar &} - exec [info nameofexecutable] {%s} 2 - close $f - } $path(gorp.file) $path(echo) $path(sleep)] + puts -nonewline $f {close stdout + set f [} + puts $f [list open $path(gorp.file) w]] + puts $f [list catch \ + [list exec [info nameofexecutable] $path(echo) foobar &]] + puts $f [list exec [info nameofexecutable] $path(sleep) 2] + puts $f {close $f} close $f catch {exec [interpreter] $path(script)} result set f [open $path(gorp.file) r] diff --git a/tests/io.test b/tests/io.test index e9531e1..8ce7f4e 100644 --- a/tests/io.test +++ b/tests/io.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: io.test,v 1.40.2.2 2003/10/07 21:37:48 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.40.2.3 2004/02/25 23:38:16 dgp Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -1582,20 +1582,21 @@ set path(test3) [makeFile {} test3] test io-14.3 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec openpipe} { set f [open $path(test1) w] - puts $f [format { + puts -nonewline $f { close stdin close stdout close stderr - set f [open "%s" r] - set f2 [open "%s" w] - set f3 [open "%s" w] - puts stdout [gets stdin] + set f [} + puts $f [list open $path(test1) r]] + puts $f "set f2 \[[list open $path(test2) w]]" + puts $f "set f3 \[[list open $path(test3) w]]" + puts $f { puts stdout [gets stdin] puts stdout out puts stderr err close $f close $f2 close $f3 - } $path(test1) $path(test2) $path(test3)] + } close $f set result [exec [interpreter] $path(test1)] set f [open $path(test2) r] @@ -1611,19 +1612,20 @@ out # This test relies on the fact that the smallest available fd is used first. test io-14.4 {Tcl_SetStdChannel & Tcl_GetStdChannel} {exec unixOnly} { set f [open $path(test1) w] - puts $f [format { close stdin + puts -nonewline $f { close stdin close stdout close stderr - set f [open "%s" r] - set f2 [open "%s" w] - set f3 [open "%s" w] - puts stdout [gets stdin] + set f [} + puts $f [list open $path(test1) r]] + puts $f "set f2 \[[list open $path(test2) w]]" + puts $f "set f3 \[[list open $path(test3) w]]" + puts $f { puts stdout [gets stdin] puts stdout $f2 puts stderr $f3 close $f close $f2 close $f3 - } $path(test1) $path(test2) $path(test3)] + } close $f set result [exec [interpreter] $path(test1)] set f [open $path(test2) r] @@ -1674,14 +1676,18 @@ test io-14.8 {reuse of stdio special channels} {stdio openpipe} { file delete $path(script) file delete $path(test1) set f [open $path(script) w] - puts $f [format { + puts -nonewline $f { close stderr - set f [open "%s" w] + set f [} + puts $f [list open $path(test1) w]] + puts -nonewline $f { puts stderr hello close $f - set f [open "%s" r] + set f [} + puts $f [list open $path(test1) r]] + puts $f { puts [gets $f] - } $path(test1) $path(test1)] + } close $f set f [open "|[list [interpreter] $path(script)]" r] set c [gets $f] @@ -1876,12 +1882,14 @@ set path(stdout) [makeFile {} stdout] test io-20.5 {Tcl_CreateChannel: install channel in empty slot} {stdio openpipe} { set f [open $path(script) w] - puts $f [format { + puts -nonewline $f { close stdout - set f1 [open "%s" w] + set f1 [} + puts $f [list open $path(stdout) w]] + puts $f { fconfigure $f1 -buffersize 777 puts stderr [fconfigure stdout -buffersize] - } $path(stdout)] + } close $f set f [open "|[list [interpreter] $path(script)]"] catch {close $f} msg @@ -2029,15 +2037,15 @@ test io-27.6 {FlushChannel, async flushing, async close} \ file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] - puts $f [format { - set f [open "%s" w] + puts $f "set f \[[list open $path(output) w]]" + puts $f { fconfigure $f -translation lf -buffering none -eofchar {} while {![eof stdin]} { after 20 puts -nonewline $f [read stdin 1024] } close $f - } $path(output)] + } close $f set x 01234567890123456789012345678901 for {set i 0} {$i < 11} {incr i} { @@ -2295,12 +2303,12 @@ test io-29.12 {Tcl_WriteChars on a pipe} {stdio openpipe} { file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] - puts $f1 [format { - set f1 [open "%s" r] + puts $f1 "set f1 \[[list open $path(longfile) r]]" + puts $f1 { for {set x 0} {$x < 10} {incr x} { puts [gets $f1] } - } $path(longfile)] + } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r] set f2 [open $path(longfile) r] @@ -2591,7 +2599,7 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} { file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] - puts $f [format {set f [open "%s" w]} $path(output)] + puts $f "set f \[[list open $path(output) w]]" puts $f {fconfigure $f -translation lf} set x [list while {![eof stdin]}] set x "$x {" @@ -2628,7 +2636,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ file delete $path(pipe) file delete $path(output) set f [open $path(pipe) w] - puts $f [format {set f [open {%s} w]} $path(output)] + puts $f "set f \[[list open $path(output) w]]" puts $f {fconfigure $f -translation lf} set x [list while {![eof stdin]}] set x "$x \{" @@ -2663,13 +2671,12 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \ } ok test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} { set f [open $path(script) w] - puts $f [format { - set f [open "%s" w] - fconfigure $f -translation lf + puts $f "set f \[[list open $path(test1) w]]" + puts $f {fconfigure $f -translation lf puts $f hello puts $f bye puts $f strange - } $path(test1)] + } close $f exec [interpreter] $path(script) set f [open $path(test1) r] @@ -5521,14 +5528,15 @@ testConstraint testfevent [llength [info commands testfevent]] test io-46.1 {Tcl event loop vs multiple interpreters} {testfevent fileevent} { testfevent create - testfevent cmd [format { - set f [open {%s} r] + set script "set f \[[list open $path(foo) r]]\n" + append script { set x "no event" fileevent $f readable [namespace code { set x "f triggered: [gets $f]" fileevent $f readable {} }] - } $path(foo)] + } + testfevent cmd $script after 1 ;# We must delay because Windows takes a little time to notice update testfevent cmd {close $f} @@ -5756,8 +5764,8 @@ test io-48.3 {testing readability conditions} {stdio unixOnly nonBlockFiles open } set l "" variable x not_done - puts $f [format {source {%s}} $path(my_script)] - puts $f [format {set f [open {%s} r]} $path(bar)] + puts $f [list source $path(my_script)] + puts $f "set f \[[list open $path(bar) r]]" puts $f {copy_slowly $f} puts $f {exit} vwait [namespace which -variable x] @@ -6659,16 +6667,18 @@ test io-53.3 {CopyData: background read underflow} {stdio unixOnly openpipe fcop file delete $path(test1) file delete $path(pipe) set f1 [open $path(pipe) w] - puts $f1 [format { + puts -nonewline $f1 { puts ready flush stdout ;# Don't assume line buffered! fcopy stdin stdout -command { set x } vwait x - set f [open "%s" w] + set f [} + puts $f1 [list open $path(test1) w]] + puts $f1 { fconfigure $f -translation lf puts $f "done" close $f - } $path(test1)] + } close $f1 set f1 [open "|[list [interpreter] $path(pipe)]" r+] set result [gets $f1] diff --git a/tests/pid.test b/tests/pid.test index 9e8fcce..45c1278 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.8.2.1 2003/10/07 18:53:23 dgp Exp $ +# RCS: @(#) $Id: pid.test,v 1.8.2.2 2004/02/25 23:38:17 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -33,7 +33,7 @@ test pid-1.2 {pid command} -constraints {unixOrPc unixExecs} -setup { set path(test1) [makeFile {} test1] file delete $path(test1) } -body { - set f [open [format {| echo foo | cat {>%s}} $path(test1)] w] + set f [open |[list echo foo | cat >$path(test1)] w] set pids [pid $f] close $f list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ diff --git a/tests/socket.test b/tests/socket.test index 61d461d..63e7a26 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.26.2.1 2003/10/07 18:53:23 dgp Exp $ +# RCS: @(#) $Id: socket.test,v 1.26.2.2 2004/02/25 23:38:17 dgp Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -1415,17 +1415,19 @@ test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] - puts $f [format { + puts -nonewline $f { set f [socket -server accept 0] puts [lindex [fconfigure $f -sockname] 2] proc accept { file addr port } { close $file } - exec $tcltest "%s" & + exec $tcltest } + puts $f [list $path(script1) &] + puts $f { close $f after 1000 exit vwait forever - } $path(script1)] + } close $f # Launch script2 and wait 5 seconds @@ -1469,15 +1471,17 @@ test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] - puts $f [format { + puts -nonewline $f { gets stdin port set f [socket 127.0.0.1 $port] - exec $tcltest "%s" & + exec $tcltest } + puts $f [list $path(script1) &] + puts $f { puts $f testing flush $f after 1000 exit vwait forever - } $path(script1)] + } close $f # Create the server socket @@ -1547,17 +1551,23 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} { set f [open $path(script2) w] puts $f [list set tcltest [interpreter]] - puts $f [format { + puts -nonewline $f { set server [socket -server accept 0] puts stdout [lindex [fconfigure $server -sockname] 2] - proc accept { file host port } { + proc accept { file host port } } + puts $f \{ + puts -nonewline $f { global tcltest puts $file {test data on socket} - exec $tcltest "%s" & + exec $tcltest } + puts $f [list $path(script1) &] + puts $f { after 1000 exit } + puts $f \} + puts $f { vwait forever - } $path(script1)] + } close $f # Launch the script2 process and connect to it. See how long diff --git a/tests/source.test b/tests/source.test index c603c1b..6417af7 100644 --- a/tests/source.test +++ b/tests/source.test @@ -12,10 +12,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: source.test,v 1.8.2.1 2003/10/07 18:53:23 dgp Exp $ +# RCS: @(#) $Id: source.test,v 1.8.2.2 2004/02/25 23:38:17 dgp Exp $ -if {[catch {package require tcltest 2.0.2}]} { - puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." +if {[catch {package require tcltest 2.1}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.1 required." return } @@ -25,6 +25,7 @@ namespace eval ::tcl::test::source { namespace import ::tcltest::cleanupTests namespace import ::tcltest::makeFile namespace import ::tcltest::removeFile + namespace import ::tcltest::customMatch test source-1.1 {source command} -setup { set x "old x value" @@ -63,6 +64,18 @@ test source-1.3 {source command} -setup { removeFile source.file } -result {a b c d e f} +proc ListGlobMatch {expected actual} { + if {[llength $expected] != [llength $actual]} { + return 0 + } + foreach e $expected a $actual { + if {![string match $e $a]} { + return 0 + } + } + return 1 +} +customMatch listGlob [namespace which ListGlobMatch] test source-2.3 {source error conditions} -setup { set sourcefile [makeFile { @@ -74,7 +87,7 @@ test source-2.3 {source error conditions} -setup { list [catch {source $sourcefile} msg] $msg $::errorInfo } -cleanup { removeFile source.file -} -match glob -result [list 1 {error in sourced file} \ +} -match listGlob -result [list 1 {error in sourced file} \ {error in sourced file while executing "error "error in sourced file"" @@ -103,7 +116,7 @@ test source-2.6 {source error conditions} -setup { removeFile _non_existent_ } -body { list [catch {source $sourcefile} msg] $msg $::errorCode -} -match glob -result [list 1 \ +} -match listGlob -result [list 1 \ {couldn't read file "*_non_existent_": no such file or directory} \ {POSIX ENOENT {no such file or directory}}] diff --git a/tests/unixInit.test b/tests/unixInit.test index 27f10b9..8560a1e 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.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: unixInit.test,v 1.30.2.5 2004/02/18 01:30:14 hobbs Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.30.2.6 2004/02/25 23:38:17 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -359,10 +359,10 @@ test unixInit-7.1 {closed standard channel: Bug 772288} -constraints { } -body { set tclsh [interpreter] makeFile {puts [open /dev/null]} crash.tcl - makeFile [subst -nocommands { + makeFile " close stdin - exec $tclsh crash.tcl - }] crashtest.tcl + [list exec $tclsh crash.tcl] + " crashtest.tcl exec $tclsh crashtest.tcl } -cleanup { removeFile crash.tcl |