diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | library/tcltest/tcltest.tcl | 71 | ||||
| -rw-r--r-- | tests/cmdAH.test | 6 | ||||
| -rw-r--r-- | tests/event.test | 7 | ||||
| -rw-r--r-- | tests/http.test | 21 | ||||
| -rw-r--r-- | tests/io.test | 18 | ||||
| -rw-r--r-- | tests/iogt.test | 25 |
7 files changed, 88 insertions, 71 deletions
@@ -1,3 +1,14 @@ +2002-06-30 Don Porter <dgp@users.sourceforge.net> + + * library/tcltest/tcltest.tcl: Fixed [makeFile] and [viewFile] to + * tests/cmdAH.test: accurately reflect a file's contents. + * tests/event.test: Updated tests that depended on buggy + * tests/http.test: behavior. Also added warning messages + * tests/io.test: to "-debug 1" operations to debug test + * tests/iogt.test: calls to (make|remove)(File|Directory). + + * unix/mkLinks: `make mklinks` on 6-27 commits. + 2002-06-28 Miguel Sofer <msofer@users.sourceforge.net> * generic/tclCompile.h: modified the macro TclEmitPush to not diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 2c2f113..6e64f2e 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -16,7 +16,7 @@ # Contributions from Don Porter, NIST, 2002. (not subject to US copyright) # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.60 2002/06/28 19:22:55 dgp Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.61 2002/07/01 02:29:22 dgp Exp $ package require Tcl 8.3 ;# uses [glob -directory] namespace eval tcltest { @@ -804,6 +804,10 @@ proc tcltest::DebugDo {level script} { ##################################################################### +proc tcltest::Warn {msg} { + puts [outputChannel] "WARNING: $msg" +} + # tcltest::mainThread # # Accessor command for tcltest variable mainThread. @@ -1341,7 +1345,7 @@ proc tcltest::ProcessFlags {flagArray} { append msg [join [lrange $moreOptions 0 end -1] ", "] append msg "or [lindex $moreOptions end]" } - puts [errorChannel] "WARNING: $msg" + Warn $msg } } else { # error is something other than "unknown option" @@ -2290,6 +2294,7 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} { if {!$calledFromAllFile} { foreach file $filesMade { if {[file exists $file]} { + DebugDo 1 {Warn "cleanupTests deleting $file..."} catch {file delete -force $file} } } @@ -2885,17 +2890,11 @@ proc tcltest::makeFile {contents name {directory ""}} { set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]:\ - putting $contents into $fullName" + putting ``$contents'' into $fullName" set fd [open $fullName w] - fconfigure $fd -translation lf - - if {[string equal [string index $contents end] "\n"]} { - puts -nonewline $fd $contents - } else { - puts $fd $contents - } + puts -nonewline $fd $contents close $fd if {[lsearch -exact $filesMade $fullName] == -1} { @@ -2919,12 +2918,25 @@ proc tcltest::makeFile {contents name {directory ""}} { # None. proc tcltest::removeFile {name {directory ""}} { + variable filesMade FillFilesExisted if {[llength [info level 0]] == 2} { set directory [temporaryDirectory] } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not created by makeFile" + } + } + if {![file isfile $fullName]} { + DebugDo 1 { + Warn "removeFile removing \"$fullName\":\n not a file" + } + } return [file delete $fullName] } @@ -2976,12 +2988,26 @@ proc tcltest::makeDirectory {name {directory ""}} { # None proc tcltest::removeDirectory {name {directory ""}} { + variable filesMade FillFilesExisted if {[llength [info level 0]] == 2} { set directory [temporaryDirectory] } set fullName [file join $directory $name] DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName" + set idx [lsearch -exact $filesMade $fullName] + set filesMade [lreplace $filesMade $idx $idx] + if {$idx == -1} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not created\ + by makeDirectory" + } + } + if {![file isdirectory $fullName]} { + DebugDo 1 { + Warn "removeDirectory removing \"$fullName\":\n not a directory" + } + } return [file delete -force $fullName] } @@ -3006,16 +3032,11 @@ proc tcltest::viewFile {name {directory ""}} { set directory [temporaryDirectory] } set fullName [file join $directory $name] - if {[string equal $tcl_platform(platform) macintosh] - || ![testConstraint unixExecs]} { - set f [open $fullName] - set data [read -nonewline $f] - close $f - return $data - } else { - return [exec cat $fullName] - } - return + set f [open $fullName] + fconfigure $f -translation binary + set data [read $f] + close $f + return $data } # tcltest::bytestring -- @@ -3234,19 +3255,17 @@ namespace eval tcltest { proc ConfigureFromEnvironment {} { upvar #0 env(TCLTEST_OPTIONS) options if {[catch {llength $options} msg]} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS \"$options\":\n invalid Tcl list: $msg" + Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\ + Tcl list: $msg" return } if {[llength $::env(TCLTEST_OPTIONS)] < 2} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS: \"$options\":\n should be\ + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\ -option value ?-option value ...?" return } if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} { - puts [errorChannel] "WARNING: invalid\ - TCLTEST_OPTIONS: \"$options\":\n $msg" + Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg" return } } diff --git a/tests/cmdAH.test b/tests/cmdAH.test index cb6b2e4..6d24820 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -10,10 +10,10 @@ # 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.22 2002/06/27 12:27:35 vincentdarley Exp $ +# RCS: @(#) $Id: cmdAH.test,v 1.23 2002/07/01 02:29:22 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -1433,7 +1433,7 @@ test cmdAH-28.4 {Tcl_FileObjCmd: stat} { catch {unset stat} file stat gorp.file stat list $stat(nlink) $stat(size) $stat(type) -} {1 12 file} +} {1 11 file} test cmdAH-28.5 {Tcl_FileObjCmd: stat} {unixOnly} { catch {unset stat} file stat gorp.file stat diff --git a/tests/event.test b/tests/event.test index 8c26fee..9fa905d 100644 --- a/tests/event.test +++ b/tests/event.test @@ -9,10 +9,10 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: event.test,v 1.16 2002/06/22 04:19:47 dgp Exp $ +# RCS: @(#) $Id: event.test,v 1.17 2002/07/01 02:29:22 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest 2 + package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -217,8 +217,7 @@ test event-6.1 {BgErrorDeleteProc procedure} { close $f removeFile err.out set result -} {Unmodified -} +} {Unmodified} test event-7.1 {bgerror / regular} { set errRes {} diff --git a/tests/http.test b/tests/http.test index cabfaed..fe76873 100644 --- a/tests/http.test +++ b/tests/http.test @@ -12,10 +12,10 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # -# RCS: @(#) $Id: http.test,v 1.26 2002/06/22 04:19:47 dgp Exp $ +# RCS: @(#) $Id: http.test,v 1.27 2002/07/01 02:29:22 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2.1 namespace import -force ::tcltest::* } @@ -223,8 +223,8 @@ test http-3.11 {http::geturl querychannel with -command} { append query $sep$query set sep & } - ::tcltest::makeFile $query outdata - set fp [open outdata] + set file [makeFile $query outdata] + set fp [open $file] proc asyncCB {token} { global postResult @@ -238,14 +238,15 @@ test http-3.11 {http::geturl querychannel with -command} { # Now do async http::cleanup $t close $fp - set fp [open outdata] + set fp [open $file] set t [http::geturl $posturl -querychannel $fp -command asyncCB] set postResult [list PostStart] http::wait $t lappend testRes [http::status $t] $postResult + removeFile outdata set testRes -} {ok 122879 {Got 122880 bytes} ok {PostStart {Got 122880 bytes}}} +} {ok 122879 {Got 122879 bytes} ok {PostStart {Got 122879 bytes}}} # On Linux platforms when the client and server are on the same # host, the client is unable to read the server's response one @@ -264,8 +265,8 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { append query $sep$query set sep & } - ::tcltest::makeFile $query outdata - set fp [open outdata] + set file [makeFile $query outdata] + set fp [open $file] proc asyncCB {token} { global postResult @@ -288,6 +289,7 @@ test http-3.12 {http::geturl querychannel with aborted request} {nonPortable} { error $err } + removeFile outdata list [http::status $t] [http::code $t] } {ok {HTTP/1.0 200 Data follows}} @@ -487,8 +489,5 @@ if {[info exists httpthread]} { if {[info exist removeHttpd]} { removeFile $httpdFile } -foreach file [list outdata] { - catch {::tcltest::removeFile $file} -} ::tcltest::cleanupTests diff --git a/tests/io.test b/tests/io.test index 067db18..973fd4e 100644 --- a/tests/io.test +++ b/tests/io.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: io.test,v 1.31 2002/06/06 18:44:43 dgp Exp $ +# RCS: @(#) $Id: io.test,v 1.32 2002/07/01 02:29:22 dgp Exp $ -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 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::io { @@ -4207,7 +4207,8 @@ test io-34.10 {Tcl_Seek testing flushing of buffered input} { close $f list $x [viewFile test3] } "xyz {xyz -456}" +456 +}" test io-34.11 {Tcl_Seek testing flushing of buffered output} { set f [open test3 w] puts $f xyz\n123 @@ -4218,7 +4219,8 @@ test io-34.11 {Tcl_Seek testing flushing of buffered output} { set x [gets $f] close $f list $x [viewFile test3] -} "zzy xyzzy" +} "zzy {xyzzy +}" test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { set f [open test3 w] fconfigure $f -translation lf -eofchar {} @@ -4235,7 +4237,8 @@ test io-34.12 {Tcl_Seek testing combination of write, seek back and read} { list $x [viewFile test3] $y } {14 {xyz 123 -xyzzy} zzy} +xyzzy +} zzy} test io-34.13 {Tcl_Tell at start of file} { removeFile test1 set f1 [open test1 w] @@ -5208,7 +5211,8 @@ test io-40.7 {POSIX open access modes: EXCL} { puts $f "A test line" close $f viewFile test3 -} {A test line} +} {A test line +} test io-40.8 {POSIX open access modes: TRUNC} { removeFile test3 set f [open test3 w] diff --git a/tests/iogt.test b/tests/iogt.test index b083efb..fb3c326 100644 --- a/tests/iogt.test +++ b/tests/iogt.test @@ -10,10 +10,10 @@ # Copyright (c) 2000 Andreas Kupries. # All rights reserved. # -# RCS: @(#) $Id: iogt.test,v 1.4 2002/04/17 23:03:14 dgp Exp $ +# RCS: @(#) $Id: iogt.test,v 1.5 2002/07/01 02:29:22 dgp Exp $ -if {[catch {package require tcltest 2}]} { - puts stderr "Skipping tests in [info script]. tcltest 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::iogt { @@ -486,7 +486,7 @@ test iogt-2.0 {basic I/O going through transform} testchannel { close $fout set res -} {1 71 71} +} {1 70 70} test iogt-2.1 {basic I/O, operation trail} {testchannel unixOnly} { @@ -522,8 +522,6 @@ read query/maxRead read query/maxRead -read -query/maxRead flush/read delete/read -------- @@ -535,7 +533,6 @@ write write write write -write flush/write delete/write} @@ -572,10 +569,6 @@ read {\}\{`~!@#$} {\}\{`~!@#$} query/maxRead {} -1 read %^&*()_+-= %^&*()_+-= query/maxRead {} -1 -read { -} { -} -query/maxRead {} -1 flush/read {} {} delete/read {} *ignored* -------- @@ -587,9 +580,6 @@ write 456789,./? 456789,./? write {><;'\|":[]} {><;'\|":[]} write {\}\{`~!@#$} {\}\{`~!@#$} write %^&*()_+-= %^&*()_+-= -write { -} { -} flush/write {} {} delete/write {} *ignored*} @@ -626,15 +616,10 @@ read {><;'\|":[]\}\{`~!@#$} {><;'\|":[]\}\{`~!@#$} write {><;'\|":[]} {><;'\|":[]} write {\}\{`~!@#$} {\}\{`~!@#$} query/maxRead {} -1 -read {%^&*()_+-= -} {%^&*()_+-= -} +read %^&*()_+-= %^&*()_+-= query/maxRead {} -1 flush/read {} {} write %^&*()_+-= %^&*()_+-= -write { -} { -} delete/read {} *ignored* flush/write {} {} delete/write {} *ignored*} |