1# This file contains support code for the Tcl test suite. It is 2# normally sourced by the individual files in the test suite before 3# they run their tests. This improved approach to testing was designed 4# and initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. 5# 6# Copyright (c) 1994-1996 Sun Microsystems, Inc. 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# SCCS: @(#) defs 1.29 96/12/08 18:33:59 12 13if ![info exists VERBOSE] { 14 set VERBOSE 0 15} 16if ![info exists TESTS] { 17 set TESTS {} 18} 19 20# Check configuration information that will determine which tests 21# to run. To do this, create an array testConfig. Each element 22# has a 0 or 1 value, and the following elements are defined: 23# unixOnly - 1 means this is a UNIX platform, so it's OK 24# to run tests that only work under UNIX. 25# macOnly - 1 means this is a Mac platform, so it's OK 26# to run tests that only work on Macs. 27# pcOnly - 1 means this is a PC platform, so it's OK to 28# run tests that only work on PCs. 29# nonPortable - 1 means this the tests are being running in 30# the master Tcl/Tk development environment; 31# Some tests are inherently non-portable because 32# they depend on things like word length, file system 33# configuration, window manager, etc. These tests 34# are only run in the main Tcl development directory 35# where the configuration is well known. The presence 36# of the file "doAllTests" in this directory indicates 37# that it is safe to run non-portable tests. 38# fonts - 1 means that this platform uses fonts with 39# well-know geometries, so it is safe to run 40# tests that depend on particular font sizes. 41 42catch {unset testConfig} 43if {$tcl_platform(platform) == "unix"} { 44 set testConfig(unixOnly) 1 45} else { 46 set testConfig(unixOnly) 0 47} 48if {$tcl_platform(platform) == "macintosh"} { 49 set testConfig(macOnly) 1 50} else { 51 set testConfig(macOnly) 0 52} 53if {$tcl_platform(platform) == "windows"} { 54 set testConfig(pcOnly) 1 55} else { 56 set testConfig(pcOnly) 0 57} 58set testConfig(nonPortable) [file exists doAllTests] 59 60# If there is no "memory" command (because memory debugging isn't 61# enabled), generate a dummy command that does nothing. 62 63if {[info commands memory] == ""} { 64 proc memory args {} 65} 66 67proc print_verbose {name description script code answer} { 68 puts stdout "\n" 69 puts stdout "==== $name $description" 70 puts stdout "==== Contents of test case:" 71 puts stdout "$script" 72 if {$code != 0} { 73 if {$code == 1} { 74 puts stdout "==== Test generated error:" 75 puts stdout $answer 76 } elseif {$code == 2} { 77 puts stdout "==== Test generated return exception; result was:" 78 puts stdout $answer 79 } elseif {$code == 3} { 80 puts stdout "==== Test generated break exception" 81 } elseif {$code == 4} { 82 puts stdout "==== Test generated continue exception" 83 } else { 84 puts stdout "==== Test generated exception $code; message was:" 85 puts stdout $answer 86 } 87 } else { 88 puts stdout "==== Result was:" 89 puts stdout "$answer" 90 } 91} 92 93# test -- 94# This procedure runs a test and prints an error message if the 95# test fails. If VERBOSE has been set, it also prints a message 96# even if the test succeeds. The test will be skipped if it 97# doesn't match the TESTS variable, or if one of the elements 98# of "constraints" turns out not to be true. 99# 100# Arguments: 101# name - Name of test, in the form foo-1.2. 102# description - Short textual description of the test, to 103# help humans understand what it does. 104# constraints - A list of one or more keywords, each of 105# which must be the name of an element in 106# the array "testConfig". If any of these 107# elements is zero, the test is skipped. 108# This argument may be omitted. 109# script - Script to run to carry out the test. It must 110# return a result that can be checked for 111# correctness. 112# answer - Expected result from script. 113 114proc test {name description script answer args} { 115 global VERBOSE TESTS testConfig 116 if {[string compare $TESTS ""] != 0} then { 117 set ok 0 118 foreach test $TESTS { 119 if [string match $test $name] then { 120 set ok 1 121 break 122 } 123 } 124 if !$ok then return 125 } 126 set i [llength $args] 127 if {$i == 0} { 128 # Empty body 129 } elseif {$i == 1} { 130 # "constraints" argument exists; shuffle arguments down, then 131 # make sure that the constraints are satisfied. 132 133 set constraints $script 134 set script $answer 135 set answer [lindex $args 0] 136 foreach constraint $constraints { 137 if {![info exists testConfig($constraint)] 138 || !$testConfig($constraint)} { 139 if $VERBOSE then { 140 puts stdout "++++ $name SKIPPED" 141 } 142 return 143 } 144 } 145 } else { 146 error "wrong # args: must be \"test name description ?constraints? script answer\"" 147 } 148 memory tag $name 149 set code [catch {uplevel $script} result] 150 if {$code != 0} { 151 print_verbose $name $description $script \ 152 $code $result 153 } elseif {[string compare $result $answer] == 0} then { 154 if $VERBOSE then { 155 print_verbose $name $description $script \ 156 $code $result 157 puts stdout "++++ $name PASSED" 158 } 159 } else { 160 print_verbose $name $description $script \ 161 $code $result 162 puts stdout "---- Result should have been:" 163 puts stdout "$answer" 164 puts stdout "---- $name FAILED" 165 } 166} 167 168proc dotests {file args} { 169 global TESTS 170 set savedTests $TESTS 171 set TESTS $args 172 source $file 173 set TESTS $savedTests 174} 175 176# If the main window isn't already mapped (e.g. because the tests are 177# being run automatically) , specify a precise size for it so that the 178# user won't have to position it manually. 179 180if {![winfo ismapped .]} { 181 wm geometry . +0+0 182 update 183} 184 185# The following code can be used to perform tests involving a second 186# process running in the background. 187 188# Locate wish executable 189 190lappend auto_path [file dirname [pwd]] 191 192package require Img 193 194set wish [list [info nameofexecutable]] 195if {$wish == "{}"} { 196 set wish {} 197 puts "Unable to find wish executable, skipping multiple process tests." 198} 199 200# Create background process 201 202proc setupbg {{args ""}} { 203 global wish fd bgData 204 if {$wish == ""} { 205 error "you're not running wish so setupbg should not have been called" 206 } 207 if {[info exists fd] && ($fd != "")} { 208 cleanupbg 209 } 210 set fd [open "|$wish -geometry +0+0 -name wish $args" r+] 211 puts $fd "puts foo; flush stdout" 212 flush $fd 213 if {[gets $fd data] < 0} { 214 error "unexpected EOF from \"$wish\"" 215 } 216 if [string compare $data foo] { 217 error "unexpected output from background process \"$data\"" 218 } 219 fileevent $fd readable bgReady 220} 221 222# Send a command to the background process, catching errors and 223# flushing I/O channels 224proc dobg {command} { 225 global fd bgData bgDone 226 puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout" 227 flush $fd 228 set bgDone 0 229 set bgData {} 230 tkwait variable bgDone 231 set bgData 232} 233 234# Data arrived from background process. Check for special marker 235# indicating end of data for this command, and make data available 236# to dobg procedure. 237proc bgReady {} { 238 global fd bgData bgDone 239 set x [gets $fd] 240 if [eof $fd] { 241 fileevent $fd readable {} 242 set bgDone 1 243 } elseif {$x == "**DONE**"} { 244 set bgDone 1 245 } else { 246 append bgData $x 247 } 248} 249 250# Exit the background process, and close the pipes 251proc cleanupbg {} { 252 global fd 253 catch { 254 puts $fd "exit" 255 close $fd 256 } 257 set fd "" 258} 259 260proc makeFile {contents name} { 261 set fd [open $name w] 262 fconfigure $fd -translation lf 263 if {[string index $contents [expr [string length $contents] - 1]] == "\n"} { 264 puts -nonewline $fd $contents 265 } else { 266 puts $fd $contents 267 } 268 close $fd 269} 270 271proc removeFile {name} { 272 global tcl_platform 273 if {$tcl_platform(platform) == "macintosh"} { 274 catch {rm $name} 275 } else { 276 catch {exec rm -f $name} 277 } 278} 279