diff options
| -rw-r--r-- | tests/chanio.test | 95 | ||||
| -rw-r--r-- | tests/cmdAH.test | 252 | ||||
| -rw-r--r-- | tests/result.test | 8 | ||||
| -rw-r--r-- | tests/subst.test | 95 | ||||
| -rw-r--r-- | tests/timer.test | 308 | ||||
| -rw-r--r-- | tests/unload.test | 44 |
6 files changed, 417 insertions, 385 deletions
diff --git a/tests/chanio.test b/tests/chanio.test index e79cb97..6e8fb44 100644 --- a/tests/chanio.test +++ b/tests/chanio.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: chanio.test,v 1.11 2008/04/15 18:34:48 andreas_kupries Exp $ +# RCS: @(#) $Id: chanio.test,v 1.12 2008/04/23 15:44:37 dkf Exp $ if {[catch {package require tcltest 2}]} { chan puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -182,8 +182,6 @@ test chan-io-1.9 {Tcl_WriteChars: WriteChars} { chan puts -nonewline $f $data chan close $f lappend sizes [file size $path(test2)] - - set sizes } {19 19 19 19 19} test chan-io-2.1 {WriteBytes} { @@ -1700,40 +1698,44 @@ file1 } {file2 }} catch {interp delete z} -test chan-io-14.5 {Tcl_GetChannel: stdio name translation} { +test chan-io-14.5 {Tcl_GetChannel: stdio name translation} -setup { interp create z +} -body { chan eof stdin catch {z eval chan flush stdin} msg1 catch {z eval chan close stdin} msg2 catch {z eval chan flush stdin} msg3 - set result [list $msg1 $msg2 $msg3] + list $msg1 $msg2 $msg3 +} -cleanup { interp delete z - set result -} {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} -test chan-io-14.6 {Tcl_GetChannel: stdio name translation} { +} -result {{channel "stdin" wasn't opened for writing} {} {can not find channel named "stdin"}} +test chan-io-14.6 {Tcl_GetChannel: stdio name translation} -setup { interp create z +} -body { chan eof stdout catch {z eval chan flush stdout} msg1 catch {z eval chan close stdout} msg2 catch {z eval chan flush stdout} msg3 - set result [list $msg1 $msg2 $msg3] + list $msg1 $msg2 $msg3 +} -cleanup { interp delete z - set result -} {{} {} {can not find channel named "stdout"}} -test chan-io-14.7 {Tcl_GetChannel: stdio name translation} { +} -result {{} {} {can not find channel named "stdout"}} +test chan-io-14.7 {Tcl_GetChannel: stdio name translation} -setup { interp create z +} -body { chan eof stderr catch {z eval chan flush stderr} msg1 catch {z eval chan close stderr} msg2 catch {z eval chan flush stderr} msg3 - set result [list $msg1 $msg2 $msg3] + list $msg1 $msg2 $msg3 +} -cleanup { interp delete z - set result -} {{} {} {can not find channel named "stderr"}} +} -result {{} {} {can not find channel named "stderr"}} set path(script) [makeFile {} script] -test chan-io-14.8 {reuse of stdio special channels} {stdio openpipe} { +test chan-io-14.8 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) +} -constraints {stdio openpipe} -body { set f [open $path(script) w] chan puts -nonewline $f { chan close stderr @@ -1752,10 +1754,11 @@ test chan-io-14.8 {reuse of stdio special channels} {stdio openpipe} { set c [chan gets $f] chan close $f set c -} hello -test chan-io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { +} -result hello +test chan-io-14.9 {reuse of stdio special channels} -setup { file delete $path(script) file delete $path(test1) +} -constraints {stdio openpipe fileevent} -body { set f [open $path(script) w] chan puts $f { array set path [lindex $argv 0] @@ -1770,14 +1773,15 @@ test chan-io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} { set f [open "|[list [interpreter] $path(script) [array get path]]" r] set c [chan gets $f] chan close $f + set c +} -cleanup { # Added delay to give Windows time to stop the spawned process and clean # up its grip on the file test1. Added delete as proper test cleanup. # The failing tests were 18.1 and 18.2 as first re-users of file "test1". after 10000 file delete $path(script) file delete $path(test1) - set c -} hello +} -result hello test chan-io-15.1 {Tcl_CreateChan CloseHandler} emptyTest { } {} @@ -1802,7 +1806,6 @@ test chan-io-17.1 {GetChannelTable, DeleteChannelTable on std handles} {testchan lappend l [expr [testchannel refcount stdin] - $l1] interp delete x lappend l [expr [testchannel refcount stdin] - $l1] - set l } {0 1 0} test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stdout] @@ -1814,7 +1817,6 @@ test chan-io-17.2 {GetChannelTable, DeleteChannelTable on std handles} {testchan lappend l [expr [testchannel refcount stdout] - $l1] interp delete x lappend l [expr [testchannel refcount stdout] - $l1] - set l } {0 1 0} test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchannel} { set l1 [testchannel refcount stderr] @@ -1826,12 +1828,12 @@ test chan-io-17.3 {GetChannelTable, DeleteChannelTable on std handles} {testchan lappend l [expr [testchannel refcount stderr] - $l1] interp delete x lappend l [expr [testchannel refcount stderr] - $l1] - set l } {0 1 0} -test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { +test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] lappend l [lindex [testchannel info $f] 15] chan close $f @@ -1840,12 +1842,13 @@ test chan-io-18.1 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { } else { lappend l "very broken: $f found after being chan closed" } - string compare [string tolower $l] \ - [list 1 [format "can not find channel named \"%s\"" $f]] -} 0 -test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { + string equal [string tolower $l] \ + [list 1 "can not find channel named \"$f\""] +} -result 1 +test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete -force $path(test1) set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] lappend l [lindex [testchannel info $f] 15] interp create x @@ -1861,12 +1864,13 @@ test chan-io-18.2 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { } else { lappend l "very broken: $f found after being chan closed" } - string compare [string tolower $l] \ - [list 1 2 1 1 [format "can not find channel named \"%s\"" $f]] -} 0 -test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { + string equal [string tolower $l] \ + [list 1 2 1 1 "can not find channel named \"$f\""] +} -result 1 +test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} -setup { file delete $path(test1) set l "" +} -constraints {testchannel} -body { set f [open $path(test1) w] lappend l [lindex [testchannel info $f] 15] interp create x @@ -1880,9 +1884,9 @@ test chan-io-18.3 {Tcl_RegisterChannel, Tcl_UnregisterChannel} {testchannel} { } else { lappend l "very broken: $f found after being chan closed" } - string compare [string tolower $l] \ - [list 1 2 1 [format "can not find channel named \"%s\"" $f]] -} 0 + string equal [string tolower $l] \ + [list 1 2 1 "can not find channel named \"$f\""] +} -result 1 test chan-io-19.1 {Tcl_GetChannel->Tcl_GetStdChannel, standard handles} { chan eof stdin @@ -1894,13 +1898,14 @@ test chan-io-19.2 {testing Tcl_GetChannel, user opened handle} { chan close $f set x } 0 -test chan-io-19.3 {Tcl_GetChannel, channel not found} { - list [catch {chan eof file34} msg] $msg -} {1 {can not find channel named "file34"}} -test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel} { +test chan-io-19.3 {Tcl_GetChannel, channel not found} -body { + chan eof file34 +} -returnCodes error -result {can not find channel named "file34"} +test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} -setup { file delete $path(test1) - set f [open $path(test1) w] set l "" +} -constraints {testchannel} -body { + set f [open $path(test1) w] lappend l [chan eof $f] chan close $f if {[catch {lindex [testchannel info $f] 15} msg]} { @@ -1908,19 +1913,19 @@ test chan-io-19.4 {Tcl_CreateChannel, insertion into channel table} {testchannel } else { lappend l "very broken: $f found after being chan closed" } - string compare [string tolower $l] \ - [list 0 [format "can not find channel named \"%s\"" $f]] -} 0 + string equal [string tolower $l] \ + [list 0 "can not find channel named \"$f\""] +} -result 1 test chan-io-20.1 {Tcl_CreateChannel: initial settings} { - set a [open $path(test2) w] + set a [open $path(test2) w] set old [encoding system] encoding system ascii set f [open $path(test1) w] set x [chan configure $f -encoding] chan close $f encoding system $old - chan close $a + chan close $a set x } {ascii} test chan-io-20.2 {Tcl_CreateChannel: initial settings} {win} { diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 44316c5..79d7b4f 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.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: cmdAH.test,v 1.57 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.58 2008/04/23 15:44:37 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 @@ -30,75 +30,89 @@ global env set cmdAHwd [pwd] catch {set platform [testgetplatform]} -test cmdAH-0.1 {Tcl_BreakObjCmd, errors} { - list [catch {break foo} msg] $msg -} {1 {wrong # args: should be "break"}} +test cmdAH-0.1 {Tcl_BreakObjCmd, errors} -body { + break foo +} -returnCodes error -result {wrong # args: should be "break"} test cmdAH-0.2 {Tcl_BreakObjCmd, success} { list [catch {break} msg] $msg } {3 {}} # Tcl_CaseObjCmd is tested in case.test -test cmdAH-1.1 {Tcl_CatchObjCmd, errors} { - list [catch {catch} msg] $msg -} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}} +test cmdAH-1.1 {Tcl_CatchObjCmd, errors} -returnCodes error -body { + catch +} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} test cmdAH-1.2 {Tcl_CatchObjCmd, errors} { list [catch {catch foo bar baz} msg] $msg } {0 1} -test cmdAH-1.3 {Tcl_CatchObjCmd, errors} { - list [catch {catch foo bar baz spaz} msg] $msg -} {1 {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"}} +test cmdAH-1.3 {Tcl_CatchObjCmd, errors} -returnCodes error -body { + catch foo bar baz spaz +} -result {wrong # args: should be "catch script ?resultVarName? ?optionVarName?"} -test cmdAH-2.1 {Tcl_CdObjCmd} { - list [catch {cd foo bar} msg] $msg -} {1 {wrong # args: should be "cd ?dirName?"}} +test cmdAH-2.1 {Tcl_CdObjCmd} -returnCodes error -body { + cd foo bar +} -result {wrong # args: should be "cd ?dirName?"} set foodir [file join [temporaryDirectory] foo] -test cmdAH-2.2 {Tcl_CdObjCmd} { +test cmdAH-2.2 {Tcl_CdObjCmd} -setup { file delete -force $foodir + set oldpwd [pwd] +} -body { file mkdir $foodir cd $foodir - set result [file tail [pwd]] - cd .. + file tail [pwd] +} -cleanup { + cd $oldpwd file delete $foodir - set result -} foo -test cmdAH-2.3 {Tcl_CdObjCmd} { +} -result foo +test cmdAH-2.3 {Tcl_CdObjCmd} -setup { global env set oldpwd [pwd] set temp $env(HOME) - set env(HOME) $oldpwd file delete -force $foodir +} -body { + set env(HOME) $oldpwd file mkdir $foodir cd $foodir cd ~ - set result [string equal [pwd] $oldpwd] + string equal [pwd] $oldpwd +} -cleanup { + cd $oldpwd file delete $foodir set env(HOME) $temp - set result -} 1 -test cmdAH-2.4 {Tcl_CdObjCmd} { +} -result 1 +test cmdAH-2.4 {Tcl_CdObjCmd} -setup { global env set oldpwd [pwd] set temp $env(HOME) - set env(HOME) $oldpwd file delete -force $foodir +} -body { + set env(HOME) $oldpwd file mkdir $foodir cd $foodir cd - set result [string equal [pwd] $oldpwd] + string equal [pwd] $oldpwd +} -cleanup { + cd $oldpwd file delete $foodir set env(HOME) $temp - set result -} 1 -test cmdAH-2.5 {Tcl_CdObjCmd} { - list [catch {cd ~~} msg] $msg -} {1 {user "~" doesn't exist}} -test cmdAH-2.6 {Tcl_CdObjCmd} { - list [catch {cd _foobar} msg] $msg -} {1 {couldn't change working directory to "_foobar": no such file or directory}} -test cmdAH-2.6.1 {Tcl_CdObjCmd} { - list [catch {cd ""} msg] $msg -} {1 {couldn't change working directory to "": no such file or directory}} +} -result 1 +test cmdAH-2.5 {Tcl_CdObjCmd} -returnCodes error -body { + cd ~~ +} -result {user "~" doesn't exist} +test cmdAH-2.6 {Tcl_CdObjCmd} -returnCodes error -body { + cd _foobar +} -result {couldn't change working directory to "_foobar": no such file or directory} +test cmdAH-2.6.1 {Tcl_CdObjCmd} -returnCodes error -body { + cd "" +} -result {couldn't change working directory to "": no such file or directory} +test cmdAH-2.7 {cd} -constraints {unix nonPortable} -setup { + set dir [pwd] +} -body { + cd / + pwd +} -cleanup { + cd $dir +} -result {/} test cmdAH-2.7 {Tcl_ConcatObjCmd} { concat @@ -110,99 +124,98 @@ test cmdAH-2.9 {Tcl_ConcatObjCmd} { concat a {b c} } {a b c} -test cmdAH-3.1 {Tcl_ContinueObjCmd, errors} { - list [catch {continue foo} msg] $msg -} {1 {wrong # args: should be "continue"}} +test cmdAH-3.1 {Tcl_ContinueObjCmd, errors} -returnCodes error -body { + continue foo +} -result {wrong # args: should be "continue"} test cmdAH-3.2 {Tcl_ContinueObjCmd, success} { list [catch {continue} msg] $msg } {4 {}} -test cmdAH-4.1 {Tcl_EncodingObjCmd} { - list [catch {encoding} msg] $msg -} {1 {wrong # args: should be "encoding option ?arg ...?"}} -test cmdAH-4.2 {Tcl_EncodingObjCmd} { - list [catch {encoding foo} msg] $msg -} {1 {bad option "foo": must be convertfrom, convertto, dirs, names, or system}} -test cmdAH-4.3 {Tcl_EncodingObjCmd} { - list [catch {encoding convertto} msg] $msg -} {1 {wrong # args: should be "encoding convertto ?encoding? data"}} -test cmdAH-4.4 {Tcl_EncodingObjCmd} { - list [catch {encoding convertto foo bar} msg] $msg -} {1 {unknown encoding "foo"}} -test cmdAH-4.5 {Tcl_EncodingObjCmd} { +test cmdAH-4.1 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding +} -result {wrong # args: should be "encoding option ?arg ...?"} +test cmdAH-4.2 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding foo +} -result {bad option "foo": must be convertfrom, convertto, dirs, names, or system} +test cmdAH-4.3 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding convertto +} -result {wrong # args: should be "encoding convertto ?encoding? data"} +test cmdAH-4.4 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding convertto foo bar +} -result {unknown encoding "foo"} +test cmdAH-4.5 {Tcl_EncodingObjCmd} -setup { set system [encoding system] +} -body { encoding system jis0208 - set x [encoding convertto \u4e4e] + encoding convertto \u4e4e +} -cleanup { encoding system $system - set x -} 8C -test cmdAH-4.6 {Tcl_EncodingObjCmd} { +} -result 8C +test cmdAH-4.6 {Tcl_EncodingObjCmd} -setup { set system [encoding system] +} -body { encoding system identity - set x [encoding convertto jis0208 \u4e4e] + encoding convertto jis0208 \u4e4e +} -cleanup { encoding system $system - set x -} 8C -test cmdAH-4.7 {Tcl_EncodingObjCmd} { - list [catch {encoding convertfrom} msg] $msg -} {1 {wrong # args: should be "encoding convertfrom ?encoding? data"}} -test cmdAH-4.8 {Tcl_EncodingObjCmd} { - list [catch {encoding convertfrom foo bar} msg] $msg -} {1 {unknown encoding "foo"}} -test cmdAH-4.9 {Tcl_EncodingObjCmd} { +} -result 8C +test cmdAH-4.7 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding convertfrom +} -result {wrong # args: should be "encoding convertfrom ?encoding? data"} +test cmdAH-4.8 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding convertfrom foo bar +} -result {unknown encoding "foo"} +test cmdAH-4.9 {Tcl_EncodingObjCmd} -setup { set system [encoding system] +} -body { encoding system jis0208 - set x [encoding convertfrom 8C] + encoding convertfrom 8C +} -cleanup { encoding system $system - set x -} \u4e4e -test cmdAH-4.10 {Tcl_EncodingObjCmd} { +} -result \u4e4e +test cmdAH-4.10 {Tcl_EncodingObjCmd} -setup { set system [encoding system] +} -body { encoding system identity - set x [encoding convertfrom jis0208 8C] + encoding convertfrom jis0208 8C +} -cleanup { encoding system $system - set x -} \u4e4e -test cmdAH-4.11 {Tcl_EncodingObjCmd} { - list [catch {encoding names foo} msg] $msg -} {1 {wrong # args: should be "encoding names"}} -test cmdAH-4.12 {Tcl_EncodingObjCmd} { - list [catch {encoding system foo bar} msg] $msg -} {1 {wrong # args: should be "encoding system ?encoding?"}} -test cmdAH-4.13 {Tcl_EncodingObjCmd} { +} -result \u4e4e +test cmdAH-4.11 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding names foo +} -result {wrong # args: should be "encoding names"} +test cmdAH-4.12 {Tcl_EncodingObjCmd} -returnCodes error -body { + encoding system foo bar +} -result {wrong # args: should be "encoding system ?encoding?"} +test cmdAH-4.13 {Tcl_EncodingObjCmd} -setup { set system [encoding system] +} -body { encoding system identity - set x [encoding system] + encoding system +} -cleanup { encoding system $system - set x -} identity - -test cmdAH-5.1 {Tcl_FileObjCmd} { - list [catch file msg] $msg -} {1 {wrong # args: should be "file option ?arg ...?"}} -test cmdAH-5.2 {Tcl_FileObjCmd} { - list [catch {file x} msg] $msg -} {1 {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable}} -test cmdAH-5.3 {Tcl_FileObjCmd} { - list [catch {file exists} msg] $msg -} {1 {wrong # args: should be "file exists name"}} +} -result identity + +test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { + file +} -result {wrong # args: should be "file option ?arg ...?"} +test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { + file x +} -result {bad option "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable} +test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { + file exists +} -result {wrong # args: should be "file exists name"} test cmdAH-5.4 {Tcl_FileObjCmd} { - list [catch {file exists ""} msg] $msg -} {0 0} - -#volume - -test cmdAH-6.1 {Tcl_FileObjCmd: volumes} { - list [catch {file volumes x} msg] $msg -} {1 {wrong # args: should be "file volumes"}} -test cmdAH-6.2 {Tcl_FileObjCmd: volumes} { - set volumeList [file volumes] - if { [llength $volumeList] == 0 } { - set result 0 - } else { - set result 1 - } -} {1} + file exists "" +} 0 + +# volume +test cmdAH-6.1 {Tcl_FileObjCmd: volumes} -returnCodes error -body { + file volumes x +} -result {wrong # args: should be "file volumes"} +test cmdAH-6.2 {Tcl_FileObjCmd: volumes} -body { + lindex [file volumes] 0 +} -match glob -result ?* test cmdAH-6.3 {Tcl_FileObjCmd: volumes} {unix} { set volumeList [file volumes] catch [list glob -nocomplain [lindex $volumeList 0]*] @@ -212,28 +225,19 @@ test cmdAH-6.4 {Tcl_FileObjCmd: volumes} win { list [catch {lsearch $volumeList "c:/"} element] [expr $element != -1] [catch {list glob -nocomplain [lindex $volumeList $element]*}] } {0 1 0} -test cmdAH-6.5 {cd} {unix nonPortable} { - set dir [pwd] - cd / - set res [pwd] - cd $dir - set res -} {/} - # attributes - -test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} { +test cmdAH-7.1 {Tcl_FileObjCmd - file attrs} -setup { set foofile [makeFile abcde foo.file] catch {file delete -force $foofile} +} -body { close [open $foofile w] - set res [catch {file attributes $foofile}] + catch {file attributes $foofile} +} -cleanup { # We used [makeFile] so we undo with [removeFile] removeFile $foofile - set res -} {0} +} -result {0} # dirname - test cmdAH-8.1 {Tcl_FileObjCmd: dirname} testsetplatform { testsetplatform unix list [catch {file dirname a b} msg] $msg diff --git a/tests/result.test b/tests/result.test index cefcaed..95407b9 100644 --- a/tests/result.test +++ b/tests/result.test @@ -49,7 +49,6 @@ test result-1.8 {Tcl_SaveInterpResult} {testsaveresult} { testsaveresult object {set x 42} 1 } {42 different} - # Tcl_RestoreInterpResult is mostly tested by the previous tests except # for the following case @@ -60,9 +59,9 @@ test result-2.1 {Tcl_RestoreInterpResult} {testsaveresult} { # Tcl_DiscardInterpResult is mostly tested by the previous tests except # for the following cases -test result-3.1 {Tcl_DiscardInterpResult} {testsaveresult} { - list [catch {testsaveresult append {cd _foobar} 1} msg] $msg -} {1 {couldn't change working directory to "_foobar": no such file or directory}} +test result-3.1 {Tcl_DiscardInterpResult} -constraints testsaveresult -body { + testsaveresult append {cd _foobar} 1 +} -returnCodes error -result {couldn't change working directory to "_foobar": no such file or directory} test result-3.2 {Tcl_DiscardInterpResult} {testsaveresult} { testsaveresult free {set x 42} 1 } {42} @@ -133,7 +132,6 @@ test result-6.2 {Bug 1649062} -setup { rename foo {} } -result {foo {} {}} - # cleanup cleanupTests return diff --git a/tests/subst.test b/tests/subst.test index a336c1b..a7d6feb 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -11,19 +11,19 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: subst.test,v 1.18 2004/10/26 21:52:41 dgp Exp $ +# RCS: @(#) $Id: subst.test,v 1.19 2008/04/23 15:44:38 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2.1 namespace import -force ::tcltest::* } -test subst-1.1 {basics} { - list [catch {subst} msg] $msg -} {1 {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"}} -test subst-1.2 {basics} { - list [catch {subst a b c} msg] $msg -} {1 {bad switch "a": must be -nobackslashes, -nocommands, or -novariables}} +test subst-1.1 {basics} -returnCodes error -body { + subst +} -result {wrong # args: should be "subst ?-nobackslashes? ?-nocommands? ?-novariables? string"} +test subst-1.2 {basics} -returnCodes error -body { + subst a b c +} -result {bad switch "a": must be -nobackslashes, -nocommands, or -novariables} test subst-2.1 {simple strings} { subst {} @@ -56,12 +56,13 @@ test subst-4.2 {variable substitutions} { set a 44 subst {x$a.y{$a}.z} } {x44.y{44}.z} -test subst-4.3 {variable substitutions} { +test subst-4.3 {variable substitutions} -setup { catch {unset a} +} -body { set a(13) 82 set i 13 subst {x.$a($i)} -} {x.82} +} -result {x.82} catch {unset a} set long {This is a very long string, intentionally made so long that it will overflow the static character size for dstrings, so that @@ -70,9 +71,9 @@ set long {This is a very long string, intentionally made so long that it an error, there will be memory that isn't freed (this will be detected when the tests are run under a checking memory allocator such as Purify).} -test subst-4.4 {variable substitutions} { - list [catch {subst {$long $a}} msg] $msg -} {1 {can't read "a": no such variable}} +test subst-4.4 {variable substitutions} -returnCodes error -body { + subst {$long $a} +} -result {can't read "a": no such variable} test subst-5.1 {command substitutions} { subst {[concat {}]} @@ -113,20 +114,20 @@ test subst-5.10 {command substitutions} { list [catch {exec [info nameofexecutable] << $script} msg] $msg } {1 {missing close-bracket}} -test subst-6.1 {clear the result after command substitution} { +test subst-6.1 {clear the result after command substitution} -body { catch {unset a} - list [catch {subst {[concat foo] $a}} msg] $msg -} {1 {can't read "a": no such variable}} + subst {[concat foo] $a} +} -returnCodes error -result {can't read "a": no such variable} -test subst-7.1 {switches} { - list [catch {subst foo bar} msg] $msg -} {1 {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables}} -test subst-7.2 {switches} { - list [catch {subst -no bar} msg] $msg -} {1 {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables}} -test subst-7.3 {switches} { - list [catch {subst -bogus bar} msg] $msg -} {1 {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables}} +test subst-7.1 {switches} -returnCodes error -body { + subst foo bar +} -result {bad switch "foo": must be -nobackslashes, -nocommands, or -novariables} +test subst-7.2 {switches} -returnCodes error -body { + subst -no bar +} -result {ambiguous switch "-no": must be -nobackslashes, -nocommands, or -novariables} +test subst-7.3 {switches} -returnCodes error -body { + subst -bogus bar +} -result {bad switch "-bogus": must be -nobackslashes, -nocommands, or -novariables} test subst-7.4 {switches} { set x 123 subst -nobackslashes {abc $x [expr 1+2] \\\x41} @@ -159,28 +160,30 @@ test subst-8.4 {return in a subst} { test subst-8.5 {return in a subst} { subst {foo [return {]}; bogus code] bar} } {foo ] bar} -test subst-8.6 {return in a subst} { - list [catch {subst {foo [return {x}; bogus code bar}} msg] $msg -} {1 {missing close-bracket}} +test subst-8.6 {return in a subst} -returnCodes error -body { + subst "foo \[return {x}; bogus code bar" +} -result {missing close-bracket} test subst-8.7 {return in a subst, parse error} -body { - subst {foo [return {x} ; set a {}" ; stuff] bar} + subst {foo [return {x} ; set a {}"" ; stuff] bar} } -returnCodes error -result {extra characters after close-brace} test subst-8.8 {return in a subst, parse error} -body { - subst {foo [return {x} ; set bar baz ; set a {}" ; stuff] bar} + subst {foo [return {x} ; set bar baz ; set a {}"" ; stuff] bar} } -returnCodes error -result {extra characters after close-brace} test subst-8.9 {return in a variable subst} { subst {foo $var([return {x}]) bar} } {foo x bar} -test subst-9.1 {error in a subst} { - list [catch {subst {[error foo; bogus code]bar}} msg] $msg -} {1 foo} -test subst-9.2 {error in a subst} { - list [catch {subst {[if 1 { error foo; bogus code}]bar}} msg] $msg -} {1 foo} -test subst-9.3 {error in a variable subst} { - list [catch {subst {foo $var([error foo]) bar}} msg] $msg -} {1 foo} +test subst-9.1 {error in a subst} -body { + subst {[error foo; bogus code]bar} +} -returnCodes error -result foo +test subst-9.2 {error in a subst} -body { + subst {[if 1 { error foo; bogus code}]bar} +} -returnCodes error -result foo +test subst-9.3 {error in a variable subst} -setup { + catch {unset var} +} -body { + subst {foo $var([error foo]) bar} +} -returnCodes error -result foo test subst-10.1 {break in a subst} { subst {foo [break; bogus code] bar} @@ -225,14 +228,14 @@ test subst-12.1 {nasty case, Bug 1036649} { set res [list [catch {subst "\[subst {};"} msg] $msg] if {$msg ne "missing close-bracket"} break } - set res + return $res } {1 {missing close-bracket}} test subst-12.2 {nasty case, Bug 1036649} { for {set i 0} {$i < 10} {incr i} { set res [list [catch {subst "\[subst {}; "} msg] $msg] if {$msg ne "missing close-bracket"} break } - set res + return $res } {1 {missing close-bracket}} test subst-12.3 {nasty case, Bug 1036649} { set x 0 @@ -240,24 +243,24 @@ test subst-12.3 {nasty case, Bug 1036649} { set res [list [catch {subst "\[incr x;"} msg] $msg] if {$msg ne "missing close-bracket"} break } - list $res $x -} {{1 {missing close-bracket}} 10} + lappend res $x +} {1 {missing close-bracket} 10} test subst-12.4 {nasty case, Bug 1036649} { set x 0 for {set i 0} {$i < 10} {incr i} { set res [list [catch {subst "\[incr x; "} msg] $msg] if {$msg ne "missing close-bracket"} break } - list $res $x -} {{1 {missing close-bracket}} 10} + lappend res $x +} {1 {missing close-bracket} 10} test subst-12.5 {nasty case, Bug 1036649} { set x 0 for {set i 0} {$i < 10} {incr i} { set res [list [catch {subst "\[incr x"} msg] $msg] if {$msg ne "missing close-bracket"} break } - list $res $x -} {{1 {missing close-bracket}} 0} + lappend res $x +} {1 {missing close-bracket} 0} # cleanup ::tcltest::cleanupTests diff --git a/tests/timer.test b/tests/timer.test index 6eecb7c..16eff33 100644 --- a/tests/timer.test +++ b/tests/timer.test @@ -13,30 +13,36 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: timer.test,v 1.12 2005/11/09 21:28:36 kennykb Exp $ +# RCS: @(#) $Id: timer.test,v 1.13 2008/04/23 15:44:38 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } -test timer-1.1 {Tcl_CreateTimerHandler procedure} { +test timer-1.1 {Tcl_CreateTimerHandler procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x "" foreach i {100 200 1000 50 150} { after $i lappend x $i } after 200 set done 1 vwait done - set x -} {50 100 150 200} + return $x +} -cleanup { + foreach i [after info] { + after cancel $i + } +} -result {50 100 150 200} -test timer-2.1 {Tcl_DeleteTimerHandler procedure} { +test timer-2.1 {Tcl_DeleteTimerHandler procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x "" foreach i {100 200 1000 50 150} { after $i lappend x $i @@ -45,8 +51,8 @@ test timer-2.1 {Tcl_DeleteTimerHandler procedure} { after cancel lappend x 50 after 200 set done 1 vwait done - set x -} {100 200} + return $x +} -result {100 200} # No tests for Tcl_ServiceTimer or ResetTimer, since it is already tested # above. @@ -60,10 +66,11 @@ test timer-3.1 {TimerHandlerEventProc procedure: event masks} { update lappend result $x } {start fired} -test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { +test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} -setup { foreach i [after info] { after cancel $i } +} -body { foreach i {200 600 1000} { after $i lappend x $i } @@ -78,45 +85,49 @@ test timer-3.2 {TimerHandlerEventProc procedure: multiple timers} { after 400 update lappend result $x -} {200 {200 600} {200 600 1000}} -test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} { +} -result {200 {200 600} {200 600 1000}} +test timer-3.3 {TimerHandlerEventProc procedure: reentrant timer deletion} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 lappend x 100 set i [after 300 lappend x 300] after 200 after cancel $i after 400 update - set x -} 100 -test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} { + return $x +} -result 100 +test timer-3.4 {TimerHandlerEventProc procedure: all expired timers fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 lappend x a after 200 lappend x b after 300 lappend x c after 300 vwait x - set x -} {a b c} -test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + return $x +} -result {a b c} +test timer-3.5 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 {lappend x a; after 0 lappend x b} after 100 vwait x - set x -} a -test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} { + return $x +} -result a +test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't fire} -setup { foreach i [after info] { after cancel $i } +} -body { set x {} after 100 {lappend x a; after 100 lappend x b; after 100} after 100 @@ -124,15 +135,16 @@ test timer-3.6 {TimerHandlerEventProc procedure: reentrantly added timers don't set result $x vwait x lappend result $x -} {a {a b}} +} -result {a {a b}} # No tests for Tcl_DoWhenIdle: it's already tested by other tests # below. -test timer-4.1 {Tcl_CancelIdleCall procedure} { +test timer-4.1 {Tcl_CancelIdleCall procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y before set z before @@ -141,12 +153,13 @@ test timer-4.1 {Tcl_CancelIdleCall procedure} { after idle set z after3 after cancel set y after2 update idletasks - concat $x $y $z -} {after1 before after3} -test timer-4.2 {Tcl_CancelIdleCall procedure} { + list $x $y $z +} -result {after1 before after3} +test timer-4.2 {Tcl_CancelIdleCall procedure} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y before set z before @@ -155,13 +168,14 @@ test timer-4.2 {Tcl_CancelIdleCall procedure} { after idle set z after3 after cancel set x after1 update idletasks - concat $x $y $z -} {before after2 after3} + list $x $y $z +} -result {before after2 after3} -test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { +test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} -setup { foreach i [after info] { after cancel $i } +} -body { set x 1 set y 23 after idle {incr x; after idle {incr x; after idle {incr x}}} @@ -170,17 +184,17 @@ test timer-5.1 {Tcl_ServiceIdle, self-rescheduling handlers} { set result "$x $y" update idletasks lappend result $x -} {2 24 4} +} -result {2 24 4} -test timer-6.1 {Tcl_AfterCmd procedure, basics} { - list [catch {after} msg] $msg -} {1 {wrong # args: should be "after option ?arg arg ...?"}} -test timer-6.2 {Tcl_AfterCmd procedure, basics} { - list [catch {after 2x} msg] $msg -} {1 {bad argument "2x": must be cancel, idle, info, or an integer}} -test timer-6.3 {Tcl_AfterCmd procedure, basics} { - list [catch {after gorp} msg] $msg -} {1 {bad argument "gorp": must be cancel, idle, info, or an integer}} +test timer-6.1 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after +} -result {wrong # args: should be "after option ?arg arg ...?"} +test timer-6.2 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after 2x +} -result {bad argument "2x": must be cancel, idle, info, or an integer} +test timer-6.3 {Tcl_AfterCmd procedure, basics} -returnCodes error -body { + after gorp +} -result {bad argument "gorp": must be cancel, idle, info, or an integer} test timer-6.4 {Tcl_AfterCmd procedure, ms argument} { set x before after 400 {set x after} @@ -201,41 +215,44 @@ test timer-6.5 {Tcl_AfterCmd procedure, ms argument} { update list $y $x } {before after} -test timer-6.6 {Tcl_AfterCmd procedure, cancel option} { - list [catch {after cancel} msg] $msg -} {1 {wrong # args: should be "after cancel id|command"}} +test timer-6.6 {Tcl_AfterCmd procedure, cancel option} -body { + after cancel +} -returnCodes error -result {wrong # args: should be "after cancel id|command"} test timer-6.7 {Tcl_AfterCmd procedure, cancel option} { after cancel after#1 } {} test timer-6.8 {Tcl_AfterCmd procedure, cancel option} { after cancel {foo bar} } {} -test timer-6.9 {Tcl_AfterCmd procedure, cancel option} { +test timer-6.9 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before set y [after 100 set x after] after cancel $y after 200 update - set x -} {before} -test timer-6.10 {Tcl_AfterCmd procedure, cancel option} { + return $x +} -result {before} +test timer-6.10 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before after 100 set x after after cancel {set x after} after 200 update - set x -} {before} -test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { + return $x +} -result {before} +test timer-6.11 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x before after 100 set x after set id [after 300 set x after] @@ -247,11 +264,12 @@ test timer-6.11 {Tcl_AfterCmd procedure, cancel option} { after 200 update list $y $x -} {after cleared} -test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { +} -result {after cleared} +test timer-6.12 {Tcl_AfterCmd procedure, cancel option} -setup { foreach i [after info] { after cancel $i } +} -body { set x first after idle lappend x second after idle lappend x third @@ -259,12 +277,13 @@ test timer-6.12 {Tcl_AfterCmd procedure, cancel option} { after cancel {lappend x second} after cancel $i update idletasks - set x -} {first third} -test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} { + return $x +} -result {first third} +test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for command} -setup { foreach i [after info] { after cancel $i } +} -body { set x first after idle lappend x second after idle lappend x third @@ -272,12 +291,13 @@ test timer-6.13 {Tcl_AfterCmd procedure, cancel option, multiple arguments for c after cancel lappend x second after cancel $i update idletasks - set x -} {first third} -test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} { + return $x +} -result {first third} +test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, used to dump core} -setup { foreach i [after info] { after cancel $i } +} -body { set id [ after 100 { set x done @@ -285,11 +305,12 @@ test timer-6.14 {Tcl_AfterCmd procedure, cancel option, cancel during handler, u } ] vwait x -} {} -test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { +} -result {} +test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} -setup { foreach i [after info] { after cancel $i } +} -body { interp create x x eval {set a before; set b before; after idle {set a a-after}; after idle {set b b-after}} @@ -301,12 +322,12 @@ test timer-6.15 {Tcl_AfterCmd procedure, cancel option, multiple interps} { x eval {after cancel set a a-after} update idletasks lappend result $a $b [x eval {list $a $b}] +} -cleanup { interp delete x - set result -} {2 0 aaa bbb {before b-after}} -test timer-6.16 {Tcl_AfterCmd procedure, idle option} { - list [catch {after idle} msg] $msg -} {1 {wrong # args: should be "after idle script script ..."}} +} -result {2 0 aaa bbb {before b-after}} +test timer-6.16 {Tcl_AfterCmd procedure, idle option} -body { + after idle +} -returnCodes error -result {wrong # args: should be "after idle script script ..."} test timer-6.17 {Tcl_AfterCmd procedure, idle option} { set x before after idle {set x after} @@ -321,6 +342,7 @@ test timer-6.18 {Tcl_AfterCmd procedure, idle option} { update idletasks list $y $x } {before after} + set event1 [after idle event 1] set event2 [after 1000 event 2] interp create x @@ -328,120 +350,125 @@ set childEvent [x eval {after idle event in child}] test timer-6.19 {Tcl_AfterCmd, info option} { lsort [after info] } [lsort "$event1 $event2"] -test timer-6.20 {Tcl_AfterCmd, info option} { - list [catch {after info a b} msg] $msg -} {1 {wrong # args: should be "after info ?id?"}} -test timer-6.21 {Tcl_AfterCmd, info option} { - list [catch {after info $childEvent} msg] $msg -} "1 {event \"$childEvent\" doesn't exist}" +test timer-6.20 {Tcl_AfterCmd, info option} -returnCodes error -body { + after info a b +} -result {wrong # args: should be "after info ?id?"} +test timer-6.21 {Tcl_AfterCmd, info option} -returnCodes error -body { + after info $childEvent +} -result "event \"$childEvent\" doesn't exist" test timer-6.22 {Tcl_AfterCmd, info option} { list [after info $event1] [after info $event2] } {{{event 1} idle} {{event 2} timer}} - after cancel $event1 after cancel $event2 interp delete x -test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NULL} { +test timer-6.23 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 "set x ab\0cd" after 10 update string length $x -} {5} -test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NULL} { +} -result {5} +test timer-6.24 {Tcl_AfterCmd procedure, no option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after 10 update string length $x -} {5} -test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NULL} { +} -result {5} +test timer-6.25 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after cancel "set x ab\0ef" - set x [llength [after info]] + llength [after info] +} -cleanup { foreach i [after info] { after cancel $i } - set x -} {1} -test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NULL} { +} -result {1} +test timer-6.26 {Tcl_AfterCmd procedure, cancel option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after 1 set x ab\0cd after cancel set x ab\0ef - set y [llength [after info]] + llength [after info] +} -cleanup { foreach i [after info] { after cancel $i } - set y -} {1} -test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NULL} { +} -result {1} +test timer-6.27 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after idle "set x ab\0cd" update string length $x -} {5} -test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NULL} { +} -result {5} +test timer-6.28 {Tcl_AfterCmd procedure, idle option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" after idle set x ab\0cd update string length $x -} {5} -test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NULL} { +} -result {5} +test timer-6.29 {Tcl_AfterCmd procedure, info option, script with NUL} -setup { foreach i [after info] { after cancel $i } +} -body { set x "hello world" set id junk set id [after 10 set x ab\0cd] update - set y [string length [lindex [lindex [after info $id] 0] 2]] + string length [lindex [lindex [after info $id] 0] 2] +} -cleanup { foreach i [after info] { after cancel $i } - set y -} {5} +} -result 5 set event [after idle foo bar] -scan $event after#%d id - -test timer-7.1 {GetAfterEvent procedure} { - list [catch {after info xfter#$id} msg] $msg -} "1 {event \"xfter#$id\" doesn't exist}" -test timer-7.2 {GetAfterEvent procedure} { - list [catch {after info afterx$id} msg] $msg -} "1 {event \"afterx$id\" doesn't exist}" -test timer-7.3 {GetAfterEvent procedure} { - list [catch {after info after#ab} msg] $msg -} {1 {event "after#ab" doesn't exist}} -test timer-7.4 {GetAfterEvent procedure} { - list [catch {after info after#} msg] $msg -} {1 {event "after#" doesn't exist}} -test timer-7.5 {GetAfterEvent procedure} { - list [catch {after info after#${id}x} msg] $msg -} "1 {event \"after#${id}x\" doesn't exist}" -test timer-7.6 {GetAfterEvent procedure} { - list [catch {after info afterx[expr $id+1]} msg] $msg -} "1 {event \"afterx[expr $id+1]\" doesn't exist}" +scan $event after#%d lastId +test timer-7.1 {GetAfterEvent procedure} -returnCodes error -body { + after info xfter#$lastId +} -result "event \"xfter#$lastId\" doesn't exist" +test timer-7.2 {GetAfterEvent procedure} -returnCodes error -body { + after info afterx$lastId +} -result "event \"afterx$lastId\" doesn't exist" +test timer-7.3 {GetAfterEvent procedure} -returnCodes error -body { + after info after#ab +} -result {event "after#ab" doesn't exist} +test timer-7.4 {GetAfterEvent procedure} -returnCodes error -body { + after info after# +} -result {event "after#" doesn't exist} +test timer-7.5 {GetAfterEvent procedure} -returnCodes error -body { + after info after#${lastId}x +} -result "event \"after#${lastId}x\" doesn't exist" +test timer-7.6 {GetAfterEvent procedure} -returnCodes error -body { + after info afterx[expr {$lastId+1}] +} -result "event \"afterx[expr {$lastId+1}]\" doesn't exist" after cancel $event test timer-8.1 {AfterProc procedure} { @@ -474,10 +501,11 @@ test timer-8.2 {AfterProc procedure} -setup { while executing "error "After error"" ("after" script)}}} -test timer-8.3 {AfterProc procedure, deleting handler from itself} { +test timer-8.3 {AfterProc procedure, deleting handler from itself} -setup { foreach i [after info] { after cancel $i } +} -body { proc foo {} { global x set x {} @@ -489,12 +517,13 @@ test timer-8.3 {AfterProc procedure, deleting handler from itself} { after idle foo after 1000 {error "I shouldn't ever have executed"} update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} -test timer-8.4 {AfterProc procedure, deleting handler from itself} { + return $x +} -result {{{error "I shouldn't ever have executed"} timer}} +test timer-8.4 {AfterProc procedure, deleting handler from itself} -setup { foreach i [after info] { after cancel $i } +} -body { proc foo {} { global x set x {} @@ -506,8 +535,8 @@ test timer-8.4 {AfterProc procedure, deleting handler from itself} { after 1000 {error "I shouldn't ever have executed"} after idle foo update idletasks - set x -} {{{error "I shouldn't ever have executed"} timer}} + return $x +} -result {{{error "I shouldn't ever have executed"} timer}} foreach i [after info] { after cancel $i @@ -515,9 +544,9 @@ foreach i [after info] { # No test for FreeAfterPtr, since it is already tested above. - -test timer-9.1 {AfterCleanupProc procedure} { +test timer-9.1 {AfterCleanupProc procedure} -setup { catch {interp delete x} +} -body { interp create x x eval {after 200 { lappend x after @@ -537,8 +566,8 @@ test timer-9.1 {AfterCleanupProc procedure} { set x before after 300 update - set x -} {before after2 after4} + return $x +} -result {before after2 after4} test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { interp create slave @@ -552,29 +581,22 @@ test timer-10.1 {Bug 1016167: [after] overwrites imports} -setup { interp delete slave } -result ::after -test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} \ - -body { - set b ok - set a [after 0x100000001 {set b "after fired early"}] - after 100 set done 1 - vwait done - set b - } \ - -cleanup { - catch {after cancel $a} - } \ - -result ok - -test timer-11.2 {Bug 1350293: [after] negative argument} \ - -body { - set l {} - after 100 {lappend l 100; set done 1} - after -1 {lappend l -1} - vwait done - set l - } \ - -result {-1 100} - +test timer-11.1 {Bug 1350291: [after] overflowing 32-bit field} -body { + set b ok + set a [after 0x100000001 {set b "after fired early"}] + after 100 set done 1 + vwait done + return $b +} -cleanup { + catch {after cancel $a} +} -result ok +test timer-11.2 {Bug 1350293: [after] negative argument} -body { + set l {} + after 100 {lappend l 100; set done 1} + after -1 {lappend l -1} + vwait done + return $l +} -result {-1 100} # cleanup ::tcltest::cleanupTests diff --git a/tests/unload.test b/tests/unload.test index d26f012..761f05c 100644 --- a/tests/unload.test +++ b/tests/unload.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: unload.test,v 1.6 2006/12/17 03:47:08 das Exp $ +# RCS: @(#) $Id: unload.test,v 1.7 2008/04/23 15:44:38 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -41,27 +41,27 @@ set alreadyTotalLoaded [info loaded] testConstraint teststaticpkg [llength [info commands teststaticpkg]] # Basic tests: parameter testing... -test unload-1.1 {basic errors} {} { - list [catch {unload} msg] $msg -} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}" -test unload-1.2 {basic errors} {} { - list [catch {unload a b c d} msg] $msg -} "1 {wrong \# args: should be \"unload ?switches? fileName ?packageName? ?interp?\"}" -test unload-1.3 {basic errors} {} { - list [catch {unload a b foobar} msg] $msg -} {1 {could not find interpreter "foobar"}} -test unload-1.4 {basic errors} {} { - list [catch {unload {}} msg] $msg -} {1 {must specify either file name or package name}} -test unload-1.5 {basic errors} {} { - list [catch {unload {} {}} msg] $msg -} {1 {must specify either file name or package name}} -test unload-1.6 {basic errors} {} { - list [catch {unload {} Unknown} msg] $msg -} {1 {package "Unknown" is loaded statically and cannot be unloaded}} -test unload-1.7 {-nocomplain switch} {} { - list [unload -nocomplain {} Unknown] -} {{}} +test unload-1.1 {basic errors} -returnCodes error -body { + unload +} -result {wrong # args: should be "unload ?switches? fileName ?packageName? ?interp?"} +test unload-1.2 {basic errors} -returnCodes error -body { + unload a b c d +} -result {wrong # args: should be "unload ?switches? fileName ?packageName? ?interp?"} +test unload-1.3 {basic errors} -returnCodes error -body { + unload a b foobar +} -result {could not find interpreter "foobar"} +test unload-1.4 {basic errors} -returnCodes error -body { + unload {} +} -result {must specify either file name or package name} +test unload-1.5 {basic errors} -returnCodes error -body { + unload {} {} +} -result {must specify either file name or package name} +test unload-1.6 {basic errors} -returnCodes error -body { + unload {} Unknown +} -result {package "Unknown" is loaded statically and cannot be unloaded} +test unload-1.7 {-nocomplain switch} { + unload -nocomplain {} Unknown +} {} set pkgua_loaded {} set pkgua_detached {} |