diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/all | 92 | ||||
| -rw-r--r-- | tests/defs | 45 |
2 files changed, 79 insertions, 58 deletions
@@ -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 @@ -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 |