summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/basic.test60
-rw-r--r--tests/cmdMZ.test23
-rw-r--r--tests/exec.test17
-rw-r--r--tests/io.test90
-rw-r--r--tests/pid.test4
-rw-r--r--tests/socket.test32
-rw-r--r--tests/source.test23
-rw-r--r--tests/unixInit.test8
8 files changed, 157 insertions, 100 deletions
diff --git a/tests/basic.test b/tests/basic.test
index fe616b5..39895fd 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.30 2003/11/14 20:44:45 dgp Exp $
+# RCS: @(#) $Id: basic.test,v 1.31 2004/02/25 23:56:59 dgp Exp $
#
package require tcltest 2
@@ -526,63 +526,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 ce4cffd..50218de 100644
--- a/tests/cmdMZ.test
+++ b/tests/cmdMZ.test
@@ -11,15 +11,16 @@
# 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.19 2003/11/12 17:27:13 hobbs Exp $
+# RCS: @(#) $Id: cmdMZ.test,v 1.20 2004/02/25 23:56:59 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
}
namespace eval ::tcl::test::cmdMZ {
namespace import ::tcltest::cleanupTests
+ namespace import ::tcltest::customMatch
namespace import ::tcltest::makeFile
namespace import ::tcltest::removeFile
namespace import ::tcltest::temporaryDirectory
@@ -202,6 +203,20 @@ test cmdMZ-3.4 {Tcl_SourceObjCmd: error conditions} -constraints {
} -body {
list [catch {source a b} msg] $msg
} -match glob -result {1 {wrong # args: should be "source*fileName"}}
+
+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 cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set file [makeFile {
set x 146
@@ -211,7 +226,7 @@ test cmdMZ-3.5 {Tcl_SourceObjCmd: error in script} -body {
set result [list [catch {source $file} msg] $msg $errorInfo]
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 91ce220..18060f6 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.17 2003/10/07 21:45:38 dgp Exp $
+# RCS: @(#) $Id: exec.test,v 1.18 2004/02/25 23:56:59 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 fcecb26..8fe80fd 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.48 2003/11/14 20:44:46 dgp Exp $
+# RCS: @(#) $Id: io.test,v 1.49 2004/02/25 23:56:59 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 613d01f..39838d9 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.9 2003/10/07 16:37:41 dgp Exp $
+# RCS: @(#) $Id: pid.test,v 1.10 2004/02/25 23:56:59 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 3719b0f..a5d9153 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.27 2003/10/07 21:45:39 dgp Exp $
+# RCS: @(#) $Id: socket.test,v 1.28 2004/02/25 23:56:59 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 828b9da..ce2e87c 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.10 2003/10/07 21:45:39 dgp Exp $
+# RCS: @(#) $Id: source.test,v 1.11 2004/02/25 23:56:59 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 3347657..0ebf10c 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.33 2004/02/18 01:30:19 hobbs Exp $
+# RCS: @(#) $Id: unixInit.test,v 1.34 2004/02/25 23:56:59 dgp Exp $
package require tcltest 2
namespace import -force ::tcltest::*
@@ -358,10 +358,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
generated by cgit v0.12 at 2024-11-15 02:41:47 (GMT)