diff options
author | dgp <dgp@users.sourceforge.net> | 2003-10-07 18:53:22 (GMT) |
---|---|---|
committer | dgp <dgp@users.sourceforge.net> | 2003-10-07 18:53:22 (GMT) |
commit | a5c5a8a5df910708a4414fed2bf1e96fa1eee7bc (patch) | |
tree | 30e0b73fd2b14893d93d3968a11f609b1052e149 | |
parent | 3b21dd18dca159cc96a291b3591e9526460646de (diff) | |
download | tcl-a5c5a8a5df910708a4414fed2bf1e96fa1eee7bc.zip tcl-a5c5a8a5df910708a4414fed2bf1e96fa1eee7bc.tar.gz tcl-a5c5a8a5df910708a4414fed2bf1e96fa1eee7bc.tar.bz2 |
* tests/exec.test: Corrected temporary file management
* tests/fileSystem.test: issues uncovered by -debug 1 test
* tests/ioCmd.test: operations. Also backported some
* tests/pid.test: other fixes from the HEAD.
* tests/socket.test: [Bugs 675605, 675655]
* tests/source.test:
-rw-r--r-- | ChangeLog | 3 | ||||
-rw-r--r-- | tests/exec.test | 8 | ||||
-rw-r--r-- | tests/fileSystem.test | 9 | ||||
-rw-r--r-- | tests/ioCmd.test | 60 | ||||
-rw-r--r-- | tests/pid.test | 27 | ||||
-rw-r--r-- | tests/socket.test | 64 | ||||
-rw-r--r-- | tests/source.test | 339 |
7 files changed, 320 insertions, 190 deletions
@@ -1,5 +1,8 @@ 2003-10-07 Don Porter <dgp@users.sourceforge.net> + * tests/pid.test: Corrected temporary file management issues + uncovered by -debug 1 test operations. [Bug 675655] + * tests/fCmd.test: Run tests with the [temporaryDirectory] as the current directory, so that tests can depend on ability to write files. [Bug 575837] diff --git a/tests/exec.test b/tests/exec.test index fd80dcf..c5223aa 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 2003/02/04 18:23:35 vincentdarley Exp $ +# RCS: @(#) $Id: exec.test,v 1.16.2.1 2003/10/07 18:53:23 dgp Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -138,7 +138,7 @@ test exec-2.6 {redirecting input from immediate source, with UTF} {exec} { # I/O redirection: output to file. set path(gorp.file) [makeFile {} gorp.file] -removeFile gorp.file +file delete $path(gorp.file) test exec-3.1 {redirecting output to file} {exec} { exec [interpreter] $path(echo) "Some simple words" > $path(gorp.file) @@ -179,7 +179,7 @@ test exec-3.7 {redirecting output to file} {exec} { # I/O redirection: output and stderr to file. -removeFile gorp.file +file delete $path(gorp.file) test exec-4.1 {redirecting output and stderr to file} {exec} { exec [interpreter] "$path(echo)" "test output" >& $path(gorp.file) @@ -264,7 +264,7 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} { # I/O redirection: combinations. set path(gorp.file2) [makeFile {} gorp.file2] -removeFile gorp.file2 +file delete $path(gorp.file2) test exec-7.1 {multiple I/O redirections} {exec} { exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file) diff --git a/tests/fileSystem.test b/tests/fileSystem.test index 6e25de7..b934aed 100644 --- a/tests/fileSystem.test +++ b/tests/fileSystem.test @@ -43,6 +43,9 @@ if {[catch { tcltest::testConstraint hasLinks 1 } +tcltest::testConstraint testsimplefilesystem \ + [string equal testsimplefilesystem [info commands testsimplefilesystem]] + test filesystem-1.0 {link normalisation} {hasLinks} { string equal [file normalize gorp.file] [file normalize link.file] } {0} @@ -389,7 +392,7 @@ test filesystem-6.33 {empty file name} { while {![catch {testfilesystem 0}]} {} } -test filesystem-7.1 {load from vfs} {win} { +test filesystem-7.1 {load from vfs} {win testsimplefilesystem} { # This may cause a crash on exit set dir [pwd] cd [file dirname [info nameof]] @@ -403,7 +406,8 @@ test filesystem-7.1 {load from vfs} {win} { # The real result of this test is what happens when Tcl exits. } {ok} -test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} { +test filesystem-7.2 {cross-filesystem copy from vfs maintains mtime} \ + {testsimplefilesystem} { set dir [pwd] cd [tcltest::temporaryDirectory] # We created this file several tests ago. @@ -455,7 +459,6 @@ test filesystem-8.2 {relative path objects and use of pwd} { cd .. removeFile [file join abc foo] removeDirectory abc - removeDirectory def cd $origdir set res } {1} diff --git a/tests/ioCmd.test b/tests/ioCmd.test index a9b7ac6..448b222 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -12,15 +12,14 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.16.2.1 2003/10/07 14:55:49 dgp Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.16.2.2 2003/10/07 18:53:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest namespace import -force ::tcltest::* } -removeFile test1 -removeFile pipe +testConstraint fcopy [llength [info commands fcopy]] test iocmd-1.1 {puts command} { list [catch {puts} msg] $msg @@ -122,7 +121,7 @@ test iocmd-4.7 {read command} { list [catch {read -nonewline stdout} msg] $msg } {1 {channel "stdout" wasn't opened for reading}} test iocmd-4.8 {read command with incorrect combination of arguments} { - removeFile test1 + file delete $path(test1) set f [open $path(test1) w] puts $f "Two lines: this one" puts $f "and this one" @@ -198,7 +197,7 @@ test iocmd-8.3 {fconfigure command} { list [catch {fconfigure a b} msg] $msg } {1 {can not find channel named "a"}} test iocmd-8.4 {fconfigure command} { - removeFile test1 + file delete $path(test1) set f1 [open $path(test1) w] set x [list [catch {fconfigure $f1 froboz} msg] $msg] close $f1 @@ -211,7 +210,7 @@ test iocmd-8.6 {fconfigure command} { list [catch {fconfigure stdin -translation froboz} msg] $msg } {1 {bad value for -translation: must be one of auto, binary, cr, lf, crlf, or platform}} test iocmd-8.7 {fconfigure command} { - removeFile test1 + file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation lf -eofchar {} -encoding unicode set x [fconfigure $f1] @@ -219,7 +218,7 @@ test iocmd-8.7 {fconfigure command} { set x } {-blocking 1 -buffering full -buffersize 4096 -encoding unicode -eofchar {} -translation lf} test iocmd-8.8 {fconfigure command} { - removeFile test1 + file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation lf -buffering line -buffersize 3030 \ -eofchar {} -encoding unicode @@ -230,7 +229,7 @@ test iocmd-8.8 {fconfigure command} { set x } {line {-blocking 1 -buffering line -buffersize 3030 -encoding unicode -eofchar {} -translation lf}} test iocmd-8.9 {fconfigure command} { - removeFile test1 + file delete $path(test1) set f1 [open $path(test1) w] fconfigure $f1 -translation binary -buffering none -buffersize 4040 \ -eofchar {} -encoding binary @@ -365,7 +364,7 @@ test iocmd-10.5 {fblocked command} { set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] -removeFile test5 +file delete $path(test5) test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} { set f [open $path(test4) w] close $f @@ -379,7 +378,7 @@ test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} { } {1 {can't read output from command: standard output was redirected} NONE} test iocmd-12.1 {POSIX open access modes: RDONLY} { - removeFile test1 + file delete $path(test1) set f [open $path(test1) w] puts $f "Two lines: this one" puts $f "and this one" @@ -391,18 +390,18 @@ test iocmd-12.1 {POSIX open access modes: RDONLY} { "{Two lines: this one} 1 [list [format "channel \"%s\" wasn't opened for writing" $f]]" } 0 test iocmd-12.2 {POSIX open access modes: RDONLY} -match regexp -body { - removeFile test3 + file delete $path(test3) open $path(test3) RDONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test iocmd-12.3 {POSIX open access modes: WRONLY} -match regexp -body { - removeFile test3 + file delete $path(test3) open $path(test3) WRONLY } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} # # Test 13.4 relies on assigning the same channel name twice. # test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} { - removeFile test3 + file delete $path(test3) set f [open $path(test3) w] fconfigure $f -eofchar {} puts $f xyzzy @@ -421,7 +420,7 @@ test iocmd-12.4 {POSIX open access modes: WRONLY} {unixOnly} { string compare $x $y } 0 test iocmd-12.5 {POSIX open access modes: RDWR} -match regexp -body { - removeFile test3 + file delete $path(test3) open $path(test3) RDWR } -returnCodes error -result {(?i)couldn't open ".*test3": no such file or directory} test iocmd-12.6 {POSIX open access modes: errors} { @@ -437,6 +436,7 @@ test iocmd-12.7 {POSIX open access modes: errors} { test iocmd-12.8 {POSIX open access modes: errors} { list [catch {open $path(test3) {TRUNC CREAT}} msg] $msg } {1 {access mode must include either RDONLY, WRONLY, or RDWR}} +close [open $path(test3) w] test iocmd-13.1 {errors in open command} { list [catch {open} msg] $msg @@ -495,19 +495,19 @@ test iocmd-14.10 {file id parsing errors} { list [catch {eof $f} msg] $msg } $expect -test iocmd-15.1 {Tcl_FcopyObjCmd} { +test iocmd-15.1 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy} msg] $msg } {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.2 {Tcl_FcopyObjCmd} { +test iocmd-15.2 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy 1} msg] $msg } {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.3 {Tcl_FcopyObjCmd} { +test iocmd-15.3 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy 1 2 3 4 5 6 7} msg] $msg } {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.4 {Tcl_FcopyObjCmd} { +test iocmd-15.4 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy 1 2 3} msg] $msg } {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} -test iocmd-15.5 {Tcl_FcopyObjCmd} { +test iocmd-15.5 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy 1 2 3 4 5} msg] $msg } {1 {wrong # args: should be "fcopy input output ?-size size? ?-command callback?"}} @@ -519,25 +519,25 @@ close $f set rfile [open $path(test1) r] set wfile [open $path(test2) w] -test iocmd-15.6 {Tcl_FcopyObjCmd} { +test iocmd-15.6 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy foo $wfile} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.7 {Tcl_FcopyObjCmd} { +test iocmd-15.7 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile foo} msg] $msg } {1 {can not find channel named "foo"}} -test iocmd-15.8 {Tcl_FcopyObjCmd} { +test iocmd-15.8 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $wfile $wfile} msg] $msg } "1 {channel \"$wfile\" wasn't opened for reading}" -test iocmd-15.9 {Tcl_FcopyObjCmd} { +test iocmd-15.9 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $rfile} msg] $msg } "1 {channel \"$rfile\" wasn't opened for writing}" -test iocmd-15.10 {Tcl_FcopyObjCmd} { +test iocmd-15.10 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile foo bar} msg] $msg } {1 {bad switch "foo": must be -size or -command}} -test iocmd-15.11 {Tcl_FcopyObjCmd} { +test iocmd-15.11 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -size foo} msg] $msg } {1 {expected integer but got "foo"}} -test iocmd-15.12 {Tcl_FcopyObjCmd} { +test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { list [catch {fcopy $rfile $wfile -command bar -size foo} msg] $msg } {1 {expected integer but got "foo"}} @@ -546,12 +546,12 @@ close $wfile # cleanup foreach file [list test1 test2 test3 test4] { - catch {::tcltest::removeFile $file} + removeFile $file } # delay long enough for background processes to finish after 500 -foreach file [list test5 pipe output] { - catch {::tcltest::removeFile $file} +foreach file [list test5] { + removeFile $file } -::tcltest::cleanupTests +cleanupTests return diff --git a/tests/pid.test b/tests/pid.test index 0bc3d24..9e8fcce 100644 --- a/tests/pid.test +++ b/tests/pid.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: pid.test,v 1.8 2003/02/25 22:03:45 andreas_kupries Exp $ +# RCS: @(#) $Id: pid.test,v 1.8.2.1 2003/10/07 18:53:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } @@ -26,27 +26,33 @@ if {[info commands pid] == ""} { return } -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} { +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 pids [pid $f] close $f - catch {removeFile test1} list [llength $pids] [regexp {^[0-9]+$} [lindex $pids 0]] \ [regexp {^[0-9]+$} [lindex $pids 1]] \ [expr {[lindex $pids 0] == [lindex $pids 1]}] -} {2 1 1 0} -test pid-1.3 {pid command} { +} -cleanup { + removeFile test1 +} -result {2 1 1 0} +test pid-1.3 {pid command} -setup { + set path(test1) [makeFile {} test1] + file delete $path(test1) +} -body { set f [open $path(test1) w] set pids [pid $f] close $f set pids -} {} +} -cleanup { + removeFile test1 +} -result {} test pid-1.4 {pid command} { list [catch {pid a b} msg] $msg } {1 {wrong # args: should be "pid ?channelId?"}} @@ -55,7 +61,6 @@ test pid-1.5 {pid command} { } {1 {can not find channel named "gorp"}} # cleanup -catch {::tcltest::removeFile test1} ::tcltest::cleanupTests return diff --git a/tests/socket.test b/tests/socket.test index 1f95749..61d461d 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 2002/07/10 11:56:45 dgp Exp $ +# RCS: @(#) $Id: socket.test,v 1.26.2.1 2003/10/07 18:53:23 dgp Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -246,7 +246,7 @@ test socket-1.12 {arg parsing for socket command} {socket} { set path(script) [makeFile {} script] test socket-2.1 {tcp connection} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 10000 "set x timed_out"] @@ -284,7 +284,7 @@ if [info exists port] { set port [expr 2048 + [pid]%1024] } test socket-2.2 {tcp connection with client port specified} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] @@ -320,7 +320,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} { set x } [list ready "hello $port"] test socket-2.3 {tcp connection with client interface specified} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] @@ -351,7 +351,7 @@ test socket-2.3 {tcp connection with client interface specified} {socket stdio} set x } {ready {hello 127.0.0.1}} test socket-2.4 {tcp connection with server interface specified} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] @@ -384,7 +384,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio} set x } {ready hello} test socket-2.5 {tcp connection with redundant server port} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] @@ -427,7 +427,7 @@ test socket-2.6 {tcp connection} {socket} { set status } ok test socket-2.7 {echo server, one line} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] @@ -467,8 +467,9 @@ test socket-2.7 {echo server, one line} {socket stdio} { close $f list $x $y } {{hello abcdefghijklmnop} done} -test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { - makeFile { +removeFile script +test socket-2.8 {echo server, loop 50 times, single connection} -constraints {socket stdio} -setup { + set path(script) [makeFile { set f [socket -server accept 0] proc accept {s a p} { fileevent $s readable [list echo $s] @@ -494,7 +495,8 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { after cancel $timer close $f puts "done $i" - } script + } script] +} -body { set f [open "|[list [interpreter] $path(script)]" r] gets $f gets $f listen @@ -510,10 +512,13 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { catch {set x [gets $f]} close $f set x -} {done 50} +} -cleanup { + removeFile script +} -result {done 50} +set path(script) [makeFile {} script] test socket-2.9 {socket conflict} {socket stdio} { set s [socket -server accept 0] - removeFile script + file delete $path(script) set f [open $path(script) w] puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" close $f @@ -579,7 +584,7 @@ test socket-2.11 {detecting new data} {socket} { test socket-3.1 {socket conflict} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set f [socket -server accept 0] @@ -599,7 +604,7 @@ test socket-3.1 {socket conflict} {socket stdio} { set x } {1 {couldn't open socket: address already in use}} test socket-3.2 {server with several clients} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set t1 [after 30000 "set x timed_out"] @@ -659,7 +664,7 @@ test socket-3.2 {server with several clients} {socket stdio} { } {ready done} test socket-4.1 {server with several clients} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set port [gets stdin] @@ -759,7 +764,7 @@ test socket-5.3 {byte order problems, socket numbers, htons} \ } {couldn't open socket: not owner} test socket-6.1 {accept callback error} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { gets stdin port @@ -784,7 +789,7 @@ test socket-6.1 {accept callback error} {socket stdio} { } {{divide by zero}} test socket-7.1 {testing socket specific options} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set ss [socket -server accept 0] @@ -812,7 +817,7 @@ test socket-7.1 {testing socket specific options} {socket stdio} { lappend l [llength $p] } {0 0 3} test socket-7.2 {testing socket specific options} {socket stdio} { - removeFile script + file delete $path(script) set f [open $path(script) w] puts $f { set ss [socket -server accept 2821] @@ -1391,8 +1396,8 @@ set path(script1) [makeFile {} script1] set path(script2) [makeFile {} script2] test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} { - removeFile script1 - removeFile script2 + file delete $path(script1) + file delete $path(script2) # Script1 is just a 10 second delay. If the server socket # is inherited, it will be held open for 10 seconds @@ -1441,14 +1446,12 @@ test socket-12.1 {testing inheritance of server sockets} {socket stdio exec} { set x {server socket was inherited} } - removeFile script1 - removeFile script2 close $p set x } {server socket was not inherited} test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} { - removeFile script1 - removeFile script2 + file delete $path(script1) + file delete $path(script2) # Script1 is just a 20 second delay. If the server socket # is inherited, it will be held open for 10 seconds @@ -1528,14 +1531,12 @@ test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} { if {!$failed} { vwait failed } - removeFile script1 - removeFile script2 close $p set x } {client socket was not inherited} test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} { - removeFile script1 - removeFile script2 + file delete $path(script1) + file delete $path(script2) set f [open $path(script1) w] puts $f { @@ -1605,8 +1606,6 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} { vwait x - removeFile script1 - removeFile script2 close $p set x } {accepted socket was not inherited} @@ -1614,7 +1613,7 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} { test socket-13.1 {Testing use of shared socket between two threads} \ {socket testthread} { - removeFile script + file delete $path(script1) threadReap makeFile { @@ -1668,6 +1667,9 @@ test socket-13.1 {Testing use of shared socket between two threads} \ } {hello 1} +removeFile script1 +removeFile script2 + # cleanup if {[string match sock* $commandSocket] == 1} { puts $commandSocket exit diff --git a/tests/source.test b/tests/source.test index f245d05..c603c1b 100644 --- a/tests/source.test +++ b/tests/source.test @@ -7,187 +7,304 @@ # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 by Scriptics Corporation. +# Contributions from Don Porter, NIST, 2003. (not subject to US copyright) # # 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 2002/07/05 10:38:43 dkf Exp $ +# RCS: @(#) $Id: source.test,v 1.8.2.1 2003/10/07 18:53:23 dgp Exp $ -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* +if {[catch {package require tcltest 2.0.2}]} { + puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." + return } -set sourcefile [makeFile "" source.file] -test source-1.1 {source command} { +namespace eval ::tcl::test::source { + namespace import ::tcltest::test + namespace import ::tcltest::testConstraint + namespace import ::tcltest::cleanupTests + namespace import ::tcltest::makeFile + namespace import ::tcltest::removeFile + +test source-1.1 {source command} -setup { set x "old x value" set y "old y value" set z "old z value" - makeFile { + set sourcefile [makeFile { set x 22 set y 33 set z 44 - } source.file + } source.file] +} -body { source $sourcefile list $x $y $z -} {22 33 44} -test source-1.2 {source command} { - makeFile {list result} source.file +} -cleanup { + removeFile source.file +} -result {22 33 44} + +test source-1.2 {source command} -setup { + set sourcefile [makeFile {list result} source.file] +} -body { source $sourcefile -} result -test source-1.3 {source command} { - set y {\ } +} -cleanup { + removeFile source.file +} -result result +test source-1.3 {source command} -setup { + set sourcefile [makeFile {} source.file] set fd [open $sourcefile w] fconfigure $fd -translation lf - puts -nonewline $fd "list a b c " - puts $fd [string index $y 0] + puts $fd "list a b c \\" puts $fd "d e f" close $fd - +} -body { source $sourcefile -} {a b c d e f} +} -cleanup { + removeFile source.file +} -result {a b c d e f} -test source-2.3 {source error conditions} { - makeFile { + +test source-2.3 {source error conditions} -setup { + set sourcefile [makeFile { set x 146 error "error in sourced file" set y $x - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo -} [list 1 {error in sourced file} "error in sourced file + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo +} -cleanup { + removeFile source.file +} -match glob -result [list 1 {error in sourced file} \ + {error in sourced file while executing -\"error \"error in sourced file\"\" - (file \"$sourcefile\" line 3) +"error "error in sourced file"" + (file "*source.file" line 3) invoked from within -\"source \$sourcefile\""] -test source-2.4 {source error conditions} { - makeFile {break} source.file - catch {source $sourcefile} -} 3 -test source-2.5 {source error conditions} { - makeFile {continue} source.file - catch {source $sourcefile} -} 4 -test source-2.6 {source error conditions} { - normalizeMsg [list [catch {source _non_existent_} msg] $msg $errorCode] -} {1 {couldn't read file "_non_existent_": no such file or directory} {posix enoent {no such file or directory}}} - -test source-3.1 {return in middle of source file} { - makeFile { +"source $sourcefile"}] + +test source-2.4 {source error conditions} -setup { + set sourcefile [makeFile {break} source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes break + +test source-2.5 {source error conditions} -setup { + set sourcefile [makeFile {continue} source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes continue + +test source-2.6 {source error conditions} -setup { + set sourcefile [makeFile {} _non_existent_] + removeFile _non_existent_ +} -body { + list [catch {source $sourcefile} msg] $msg $::errorCode +} -match glob -result [list 1 \ + {couldn't read file "*_non_existent_": no such file or directory} \ + {POSIX ENOENT {no such file or directory}}] + + +test source-3.1 {return in middle of source file} -setup { + set sourcefile [makeFile { set x new-x return allDone set y new-y - } source.file + } source.file] +} -body { set x old-x set y old-y set z [source $sourcefile] list $x $y $z -} {new-x old-y allDone} -test source-3.2 {return with special code etc.} { - makeFile { +} -cleanup { + removeFile source.file +} -result {new-x old-y allDone} + +test source-3.2 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code break "Silly result" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg -} {3 {Silly result}} -test source-3.3 {return with special code etc.} { - makeFile { + } source.file] +} -body { + source $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes break -result {Silly result} + +test source-3.3 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error "Simulated error" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {Simulated error} {Simulated error + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {Simulated error} {Simulated error while executing "source $sourcefile"} NONE} -test source-3.4 {return with special code etc.} { - makeFile { + +test source-3.4 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {} {Simulated errorInfo stuff + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {} {Simulated errorInfo stuff invoked from within "source $sourcefile"} NONE} -test source-3.5 {return with special code etc.} { - makeFile { + +test source-3.5 {return with special code etc.} -setup { + set sourcefile [makeFile { set x new-x return -code error -errorinfo "Simulated errorInfo stuff" \ -errorcode {a b c} set y new-y - } source.file - list [catch {source $sourcefile} msg] $msg $errorInfo $errorCode -} {1 {} {Simulated errorInfo stuff + } source.file] +} -body { + list [catch {source $sourcefile} msg] $msg $::errorInfo $::errorCode +} -cleanup { + removeFile source.file +} -result {1 {} {Simulated errorInfo stuff invoked from within "source $sourcefile"} {a b c}} + # Test for the Macintosh specfic features of the source command -test source-4.1 {source error conditions} {macOnly} { - list [catch {source -rsrc _no_exist_} msg] $msg -} [list 1 "The resource \"_no_exist_\" could not be loaded from application."] -test source-4.2 {source error conditions} {macOnly} { - list [catch {source -rsrcid bad_id} msg] $msg -} [list 1 "expected integer but got \"bad_id\""] -test source-4.3 {source error conditions} {macOnly} { - list [catch {source -rsrc rsrcName fileName extra} msg] $msg -} {1 {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-4.4 {source error conditions} {macOnly} { - list [catch {source non_switch rsrcName} msg] $msg -} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-4.5 {source error conditions} {macOnly} { - list [catch {source -bad_switch argument} msg] $msg -} {1 {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?"}} -test source-5.1 {source resource files} {macOnly} { - list [catch {source -rsrc rsrcName bad_file} msg] $msg -} [list 1 "Error finding the file: \"bad_file\"."] -test source-5.2 {source resource files} {macOnly} { - makeFile {return} source.file - list [catch {source -rsrc rsrcName $sourcefile} msg] $msg -} [list 1 "Error reading the file: \"$sourcefile\"."] -test source-5.3 {source resource files} {macOnly} { - testWriteTextResource -rsrc rsrcName -file rsrc.file {set msg2 ok; return} - set result [catch {source -rsrc rsrcName rsrc.file} msg] +test source-4.1 {source error conditions} -constraints macOnly -body { + source -rsrc _no_exist_ +} -result {The resource "_no_exist_" could not be loaded from application.} \ + -returnCodes error + +test source-4.2 {source error conditions} -constraints macOnly -body { + source -rsrcid bad_id +} -returnCodes error -result {expected integer but got "bad_id"} + +test source-4.3 {source error conditions} -constraints macOnly -body { + source -rsrc rsrcName fileName extra +} -returnCodes error -result {wrong # args: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + +test source-4.4 {source error conditions} -constraints macOnly -body { + source non_switch rsrcName +} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + +test source-4.5 {source error conditions} -constraints macOnly -body { + source -bad_switch argument +} -returnCodes error -result {bad argument: should be "source fileName" or "source -rsrc name ?fileName?" or "source -rsrcid id ?fileName?" or "source -encoding name fileName"} + + +testConstraint testWriteTextResource \ + [llength [info commands testWriteTextResource]] + +test source-5.1 {source resource files} -constraints macOnly -setup { + set sourcefile [makeFile {} bad_file] + removeFile bad_file +} -body { + source -rsrc rsrcName $sourcefile +} -returnCodes error -match glob -result {Error finding the file: "*bad_file".} + +test source-5.2 {source resource files} -constraints macOnly -setup { + set sourcefile [makeFile {return} source.file] +} -body { + source -rsrc rsrcName $sourcefile +} -cleanup { + removeFile source.file +} -returnCodes error -match glob \ + -result {Error reading the file: "*source.file".} + +test source-5.3 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrc rsrcName -file $rsrc.file {set msg2 ok; return} +} -body { + set result [catch {source -rsrc rsrcName rsrc.file} msg] list $msg2 $result $msg -} [list ok 0 {}] -test source-5.4 {source resource files} {macOnly} { - catch {unset msg2} - testWriteTextResource -rsrc fileRsrcName -file rsrc.file {set msg2 ok; return} - source -rsrc fileRsrcName rsrc.file - set result [catch {source -rsrc fileRsrcName} msg] +} -cleanup { + removeFile rsrc.file +} -result [list ok 0 {}] + +test source-5.4 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrsFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrc fileRsrcName \ + -file $rsrcFile {set msg2 ok; return} +} -body { + source -rsrc fileRsrcName $rsrcFile + set result [catch {source -rsrc fileRsrcName} msg] list $msg2 $result $msg -} [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] -test source-5.5 {source resource files} {macOnly} { - testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; set msg3 bye} - set result [catch {source -rsrcid 200 rsrc.file} msg] +} -cleanup { removeFile rsrc.file +} -result [list ok 1 {The resource "fileRsrcName" could not be loaded from application.}] + +test source-5.5 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] + removeFile rsrc.file + testWriteTextResource -rsrcid 200 \ + -file $rsrcFile {set msg2 hello; set msg3 bye} +} -body { + set result [catch {source -rsrcid 200 $rsrcFile} msg] list $msg2 $result $msg -} [list hello 0 bye] -test source-5.6 {source resource files} {macOnly} { - testWriteTextResource -rsrcid 200 -file rsrc.file {set msg2 hello; error bad; set msg3 bye} - set result [catch {source -rsrcid 200 rsrc.file} msg] +} -cleanup { + removeFile rsrc.file +} -result [list hello 0 bye] + +test source-5.6 {source resource files} -constraints { + macOnly testWriteTextResource +} -setup { + set msg2 unset + set rsrcFile [makeFile {} rsrc.file] removeFile rsrc.file + testWriteTextResource -rsrcid 200 \ + -file $rsrcFile {set msg2 hello; error bad; set msg3 bye} +} -body { + set result [catch {source -rsrcid 200 rsrc.file} msg] list $msg2 $result $msg -} [list hello 1 bad] +} -cleanup { + removeFile rsrc.file +} -result [list hello 1 bad] + -test source-6.1 {source is binary ok} { +test source-6.1 {source is binary ok} -setup { + # Note [makeFile] writes in the system encoding. + # [source] defaults to reading in the system encoding. + set sourcefile [makeFile [list set x "a b\0c"] source.file] +} -body { set x {} - makeFile [list set x "a b\0c"] source.file source $sourcefile string length $x -} 5 -test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} { +} -cleanup { + removeFile source.file +} -result 5 + +test source-6.2 {source skips everything after Ctrl-Z: Bug 2040} -setup { + set sourcefile [makeFile "set x ab\32c" source.file] +} -body { set x {} - makeFile [list set x "ab\32c"] source.file source $sourcefile string length $x -} 2 +} -cleanup { + removeFile source.file +} -result 2 -# cleanup -catch {::tcltest::removeFile source.file} -::tcltest::cleanupTests +cleanupTests +} +namespace delete ::tcl::test::source return |