Update all and defs to work with nightly test environment.

Both files now pass the checker!

2 files changed, 79 insertions, 58 deletions

diff --git a/tests/all b/tests/all
index a999a76..92e7096 100644
--- a/tests/all
+++ b/tests/all
@@ -2,56 +2,76 @@
 # tests.  Execute it by invoking "source all" when running tclTest
 # in this directory.
 #
-# RCS: @(#) $Id: all,v 1.2 1998/09/14 18:23:42 stanton Exp $
+# RCS: @(#) $Id: all,v 1.3 1998/12/04 04:19:12 hershey Exp $
 
-switch $tcl_platform(platform) {
-    "windows" {
-	# Tests that cause tk to crash under windows.
-	set crash {}
+set TESTS_DIR [file join [pwd] [file dirname [info script]]]
+source [file join $TESTS_DIR defs]
+set currentDir [pwd]
 
-	# Tests that fail under windows.
+catch {array set flag $argv}
+set requiredSourceFiles [list arc.tcl bugs.tcl butGeom2.tcl \
+	canvPsBmap.tcl canvPsText.tcl bevel.tcl butGeom.tcl \
+	canvPsArc.tcl canvPsGrph.tcl cmap.tcl filebox.test \
+	option.file1 option.file2 visual defs]
 
-	set fail { grid.test }
+#
+# Set the TMP_DIR to pwd or the arg of -tmpdir, if given.
+# 
 
-	if {! [info exist exclude] } {
-	    set exclude [string tolower "$crash $fail"]
+if {[info exists flag(-tmpdir)]} {
+    set TMP_DIR $flag(-tmpdir)
+    if {![file exists $TMP_DIR]} {
+	if {[catch {file mkdir $TMP_DIR} msg]} {
+	    error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$msg"
 	}
+	file mkdir $TMP_DIR
+    } elseif {![file isdir $TMP_DIR]} {
+	error "bad argument \"$flag(-tmpdir)\" to -tmpdir:\n$TMP_DIR is not a directory"
+    }
+    if {[string compare [file pathtype $TMP_DIR] absolute] != 0} {
+	set TMP_DIR [file join [pwd] $TMP_DIR]
     }
-    "macintosh" {
-	set x [pwd]
-	cd $tk_library
-	set tk_library [pwd]
-	cd $x
-	
-	# Tests that cause tk to crash under mac.
-	set crash {}
-
-	# Tests that fail under mac.
-	set fail {bind.test entry.test send.test textDisp.test}
-	
-	set exclude [string tolower "$crash $fail"]
-    }    
-    "unix" {
-	set exclude ""
+    cd $TMP_DIR
+}
+
+#
+# copy each required source file to the current dir (if it's not already there).
+#
+
+if {[string compare $TESTS_DIR [pwd]] != 0} {
+
+    foreach file $requiredSourceFiles {
+	if {![file exists $file]} {
+	    catch {file copy [file join $TESTS_DIR $file] .}
+	}
     }
 }
 
 if {$tcl_platform(os) == "Win32s"} {
-    set tests [lsort [glob *.tes]]
+    set globPattern [file join $TESTS_DIR *.tes]
 } else {
-    set tests [lsort [glob *.test]]
+    set globPattern [file join $TESTS_DIR *.test]
 }
 
-foreach i $tests {
-    if [string match l.*.test $i] {
-	# This is an SCCS lock file;  ignore it.
+foreach file [lsort [glob $globPattern]] {
+    set tail [file tail $file]
+    if {[string match l.*.test $tail]} {
+	# This is an SCCS lockfile; ignore it
 	continue
     }
-    if [lsearch $exclude [string tolower $i]]>=0 {
-	# Do not source this file; it exercises a known bug at this time.
-	puts stdout "Skipping $i"
-	continue
+    puts stdout $tail
+    if {[catch {source $file} msg]} {
+	puts stdout $msg
     }
-    puts stdout $i
-    source $i
 }
+
+# remove the required source files from the current dir.
+if {[info exists TMP_DIR]} {
+    foreach file $requiredSourceFiles {
+        catch {file delete -force $file}
+    }
+    cd $currentDir
+}
+
+catch {destroy .}
+exit
diff --git a/tests/defs b/tests/defs
index e1f6f9b..cde64fc 100644
--- a/tests/defs
+++ b/tests/defs
@@ -4,16 +4,17 @@
 # and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
 #
 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
+# Copyright (c) 1998 by Scriptics Corporation
 #
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: defs,v 1.2 1998/09/14 18:23:45 stanton Exp $
+# RCS: @(#) $Id: defs,v 1.3 1998/12/04 04:19:12 hershey Exp $
 
-if ![info exists VERBOSE] {
+if {![info exists VERBOSE]} {
     set VERBOSE 0
 }
-if ![info exists TESTS] {
+if {![info exists TESTS]} {
     set TESTS {}
 }
 
@@ -55,11 +56,11 @@ set testConfig(unix)		$testConfig(unixOnly)
 set testConfig(mac)		$testConfig(macOnly)
 set testConfig(pc)		$testConfig(pcOnly)
 
-set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
-set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
-set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
+set testConfig(unixOrPc) [expr {$testConfig(unixOnly) || $testConfig(pcOnly)}]
+set testConfig(macOrPc) [expr {$testConfig(macOnly) || $testConfig(pcOnly)}]
+set testConfig(macOrUnix) [expr {$testConfig(macOnly) || $testConfig(unixOnly)}]
 
-set testConfig(nonPortable) 	[expr [file exists doAllTests] || [file exists DOALLT~1]]
+set testConfig(nonPortable) 	[expr {[file exists doAllTests] || [file exists DOALLT~1]}]
 
 set testConfig(nt)		[expr {$tcl_platform(os) == "Windows NT"}]
 set testConfig(95)		[expr {$tcl_platform(os) == "Windows 95"}]
@@ -68,18 +69,18 @@ set testConfig(win32s)		[expr {$tcl_platform(os) == "Win32s"}]
 # The following config switches are used to mark tests that should work,
 # but have been temporarily disabled on certain platforms because they don't.
 
-set testConfig(tempNotPc) 	[expr !$testConfig(pc)]
-set testConfig(tempNotMac) 	[expr !$testConfig(mac)]
-set testConfig(tempNotUnix)	[expr !$testConfig(unix)]
+set testConfig(tempNotPc) 	[expr {!$testConfig(pc)}]
+set testConfig(tempNotMac) 	[expr {!$testConfig(mac)}]
+set testConfig(tempNotUnix)	[expr {!$testConfig(unix)}]
 
 # The following config switches are used to mark tests that crash on
 # certain platforms, so that they can be reactivated again when the
 # underlying problem is fixed.
 
-set testConfig(pcCrash) 	[expr !$testConfig(pc)]
-set testConfig(win32sCrash) 	[expr !$testConfig(win32s)]
-set testConfig(macCrash) 	[expr !$testConfig(mac)]
-set testConfig(unixCrash) 	[expr !$testConfig(unix)]
+set testConfig(pcCrash) 	[expr {!$testConfig(pc)}]
+set testConfig(win32sCrash) 	[expr {!$testConfig(win32s)}]
+set testConfig(macCrash) 	[expr {!$testConfig(mac)}]
+set testConfig(unixCrash) 	[expr {!$testConfig(unix)}]
 
 set testConfig(fonts) 1
 catch {destroy .e}
@@ -100,10 +101,10 @@ if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
 }
 
 if {$testConfig(nonPortable) == 0} {
-    puts "(will skip non-portable tests)"
+    puts stdout "(will skip non-portable tests)"
 }
 if {$testConfig(fonts) == 0} {
-    puts "(will skip font-sensitive tests: this system has unexpected font geometries)"
+    puts stdout "(will skip font-sensitive tests: this system has unexpected font geometries)"
 }
 
 trace variable testConfig r safeFetch
@@ -231,7 +232,7 @@ proc test {name description script answer args} {
     if {$code != 0} {
 	print_verbose $name $description $script $code $result
     } elseif {[string compare $result $answer] == 0} { 
-	if {$VERBOSE} then {
+	if {$VERBOSE} {
 	    if {$VERBOSE > 0} {
 		print_verbose $name $description $script $code $result
 	    }
@@ -272,12 +273,12 @@ if {![winfo ismapped .]} {
 set tktest [info nameofexecutable]
 if {$tktest == "{}"} {
     set tktest {}
-    puts "Unable to find tktest executable, skipping multiple process tests."
+    puts stdout "Unable to find tktest executable, skipping multiple process tests."
 }
 
 # Create background process
 
-proc setupbg {{args ""}} {
+proc setupbg args {
     global tktest fd bgData
     if {$tktest == ""} {
         error "you're not running tktest so setupbg should not have been called"
@@ -291,7 +292,7 @@ proc setupbg {{args ""}} {
     if {[gets $fd data] < 0} {
         error "unexpected EOF from \"$tktest\""
     }
-    if [string compare $data foo] {
+    if {[string compare $data foo]} {
         error "unexpected output from background process \"$data\""
     }
     fileevent $fd readable bgReady
@@ -315,7 +316,7 @@ proc dobg {command} {
 proc bgReady {} {
     global fd bgData bgDone
     set x [gets $fd]
-    if [eof $fd] {
+    if {[eof $fd]} {
 	fileevent $fd readable {}
 	set bgDone 1
     } elseif {$x == "**DONE**"} {
@@ -354,7 +355,7 @@ proc fixfocus {} {
 proc makeFile {contents name} {
     set fd [open $name w]
     fconfigure $fd -translation lf
-    if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
+    if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
 	puts -nonewline $fd $contents
     } else {
 	puts $fd $contents