* Fixed [makeFile] and [viewFile] to accurately reflect a file's

	contents.  Updated tests that depended on buggy behavior.  Also
	added warning messages to "-debug 1" operations to debug test
        calls to (make|remove)(File|Directory).

7 files changed, 88 insertions, 71 deletions

diff --git a/ChangeLog b/ChangeLog
index a845990..29b49b1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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*}