summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/all92
-rw-r--r--tests/defs45
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