tk/tests/defs

   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-1997 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 # RCS: @(#) $Id$
  12
  13 if ![info exists srcdir] {
  14     set srcdir .
  15 }
  16
  17 if ![info exists VERBOSE] {
  18     set VERBOSE 0
  19 }
  20 if ![info exists TESTS] {
  21     set TESTS {}
  22 }
  23
  24 tk appname tktest
  25 wm title . tktest
  26
  27 # Check configuration information that will determine which tests
  28 # to run.  To do this, create an array testConfig.  Each element
  29 # has a 0 or 1 value, and the following elements are defined:
  30 #       unixOnly -      1 means this is a UNIX platform, so it's OK
  31 #                       to run tests that only work under UNIX.
  32 #       macOnly -       1 means this is a Mac platform, so it's OK
  33 #                       to run tests that only work on Macs.
  34 #       pcOnly -        1 means this is a PC platform, so it's OK to
  35 #                       run tests that only work on PCs.
  36 #       unixOrPc -      1 means this is a UNIX or PC platform.
  37 #       macOrPc -       1 means this is a Mac or PC platform.
  38 #       macOrUnix -     1 means this is a Mac or UNIX platform.
  39 #       nonPortable -   1 means this the tests are being running in
  40 #                       the master Tcl/Tk development environment;
  41 #                       Some tests are inherently non-portable because
  42 #                       they depend on things like word length, file system
  43 #                       configuration, window manager, etc.  These tests
  44 #                       are only run in the main Tcl development directory
  45 #                       where the configuration is well known.  The presence
  46 #                       of the file "doAllTests" in this directory indicates
  47 #                       that it is safe to run non-portable tests.
  48 #       fonts -         1 means that this platform uses fonts with
  49 #                       well-know geometries, so it is safe to run
  50 #                       tests that depend on particular font sizes.
  51
  52 catch {unset testConfig}
  53
  54 set testConfig(unixOnly)        [expr {$tcl_platform(platform) == "unix"}]
  55 set testConfig(macOnly)         [expr {$tcl_platform(platform) == "macintosh"}]
  56 set testConfig(pcOnly)          [expr {$tcl_platform(platform) == "windows"}]
  57
  58 set testConfig(unix)            $testConfig(unixOnly)
  59 set testConfig(mac)             $testConfig(macOnly)
  60 set testConfig(pc)              $testConfig(pcOnly)
  61
  62 set testConfig(unixOrPc) [expr $testConfig(unixOnly) || $testConfig(pcOnly)]
  63 set testConfig(macOrPc) [expr $testConfig(macOnly) || $testConfig(pcOnly)]
  64 set testConfig(macOrUnix) [expr $testConfig(macOnly) || $testConfig(unixOnly)]
  65
  66 set testConfig(nonPortable)     [expr [file exists doAllTests] || [file exists DOALLT~1]]
  67
  68 set testConfig(nt)              [expr {$tcl_platform(os) == "Windows NT"}]
  69 set testConfig(95)              [expr {$tcl_platform(os) == "Windows 95"}]
  70 set testConfig(win32s)          [expr {$tcl_platform(os) == "Win32s"}]
  71
  72 # The following config switches are used to mark tests that should work,
  73 # but have been temporarily disabled on certain platforms because they don't.
  74
  75 set testConfig(tempNotPc)       [expr !$testConfig(pc)]
  76 set testConfig(tempNotMac)      [expr !$testConfig(mac)]
  77 set testConfig(tempNotUnix)     [expr !$testConfig(unix)]
  78
  79 # The following config switches are used to mark tests that crash on
  80 # certain platforms, so that they can be reactivated again when the
  81 # underlying problem is fixed.
  82
  83 set testConfig(pcCrash)         [expr !$testConfig(pc)]
  84 set testConfig(win32sCrash)     [expr !$testConfig(win32s)]
  85 set testConfig(macCrash)        [expr !$testConfig(mac)]
  86 set testConfig(unixCrash)       [expr !$testConfig(unix)]
  87
  88 set testConfig(fonts) 1
  89 catch {destroy .e}
  90 entry .e -width 0 -font {Helvetica -12} -bd 1
  91 .e insert end "a.bcd"
  92 if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
  93     set testConfig(fonts) 0
  94 }
  95 destroy .e .t
  96 text .t -width 80 -height 20 -font {Times -14} -bd 1
  97 pack .t
  98 .t insert end "This is\na dot."
  99 update
 100 set x [list [.t bbox 1.3] [.t bbox 2.5]]
 101 destroy .t
 102 if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
 103     set testConfig(fonts) 0
 104 }
 105
 106 if {$testConfig(nonPortable) == 0} {
 107     puts "(will skip non-portable tests)"
 108 }
 109 if {$testConfig(fonts) == 0} {
 110     puts "(will skip font-sensitive tests: this system has unexpected font geometries)"
 111 }
 112
 113 trace variable testConfig r safeFetch
 114
 115 proc safeFetch {n1 n2 op} {
 116     global testConfig
 117
 118     if {($n2 != {}) && ([info exists testConfig($n2)] == 0)} {
 119         set testConfig($n2) 0
 120     }
 121 }
 122
 123 # If there is no "memory" command (because memory debugging isn't
 124 # enabled), generate a dummy command that does nothing.
 125
 126 if {[info commands memory] == ""} {
 127     proc memory args {}
 128 }
 129
 130 proc print_verbose {name description script code answer} {
 131     puts stdout "\n"
 132     puts stdout "==== $name $description"
 133     puts stdout "==== Contents of test case:"
 134     puts stdout "$script"
 135     if {$code != 0} {
 136         if {$code == 1} {
 137             puts stdout "==== Test generated error:"
 138             puts stdout $answer
 139         } elseif {$code == 2} {
 140             puts stdout "==== Test generated return exception;  result was:"
 141             puts stdout $answer
 142         } elseif {$code == 3} {
 143             puts stdout "==== Test generated break exception"
 144         } elseif {$code == 4} {
 145             puts stdout "==== Test generated continue exception"
 146         } else {
 147             puts stdout "==== Test generated exception $code;  message was:"
 148             puts stdout $answer
 149         }
 150     } else {
 151         puts stdout "==== Result was:"
 152         puts stdout "$answer"
 153     }
 154 }
 155
 156 # test --
 157 # This procedure runs a test and prints an error message if the
 158 # test fails.  If VERBOSE has been set, it also prints a message
 159 # even if the test succeeds.  The test will be skipped if it
 160 # doesn't match the TESTS variable, or if one of the elements
 161 # of "constraints" turns out not to be true.
 162 #
 163 # Arguments:
 164 # name -                Name of test, in the form foo-1.2.
 165 # description -         Short textual description of the test, to
 166 #                       help humans understand what it does.
 167 # constraints -         A list of one or more keywords, each of
 168 #                       which must be the name of an element in
 169 #                       the array "testConfig".  If any of these
 170 #                       elements is zero, the test is skipped.
 171 #                       This argument may be omitted.
 172 # script -              Script to run to carry out the test.  It must
 173 #                       return a result that can be checked for
 174 #                       correctness.
 175 # answer -              Expected result from script.
 176
 177 proc test {name description script answer args} {
 178     global VERBOSE TESTS testConfig
 179     if {[string compare $TESTS ""] != 0} {
 180         set ok 0
 181         foreach test $TESTS {
 182             if {[string match $test $name]} {
 183                 set ok 1
 184                 break
 185             }
 186         }
 187         if {!$ok} {
 188             return
 189         }
 190     }
 191     set i [llength $args]
 192     if {$i == 0} {
 193         # Empty body
 194     } elseif {$i == 1} {
 195         # "constraints" argument exists;  shuffle arguments down, then
 196         # make sure that the constraints are satisfied.
 197
 198         set constraints $script
 199         set script $answer
 200         set answer [lindex $args 0]
 201         set doTest 0
 202         if {[string match {*[$\[]*} $constraints] != 0} {
 203             # full expression, e.g. {$foo > [info tclversion]}
 204
 205             catch {set doTest [uplevel #0 expr $constraints]}
 206         } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
 207             # something like {a || b} should be turned into
 208             # $testConfig(a) || $testConfig(b).
 209
 210             regsub -all {[.a-zA-Z0-9]+} $constraints {$testConfig(&)} c
 211             catch {set doTest [eval expr $c]}
 212         } else {
 213             # just simple constraints such as {unixOnly fonts}.
 214
 215             set doTest 1
 216             foreach constraint $constraints {
 217                 if {![info exists testConfig($constraint)]
 218                         || !$testConfig($constraint)} {
 219                     set doTest 0
 220                     break
 221                 }
 222             }
 223         }
 224         if {$doTest == 0} {
 225             if {$VERBOSE} {
 226                 puts stdout "++++ $name SKIPPED: $constraints"
 227             }
 228             return
 229         }
 230     } else {
 231         error "wrong # args: must be \"test name description ?constraints? script answer\""
 232     }
 233     memory tag $name
 234     set code [catch {uplevel $script} result]
 235     if {$code != 0} {
 236         print_verbose $name $description $script $code $result
 237     } elseif {[string compare $result $answer] == 0} {
 238         if {$VERBOSE} then {
 239             if {$VERBOSE > 0} {
 240                 print_verbose $name $description $script $code $result
 241             }
 242             if {$VERBOSE != -2} {
 243                 puts stdout "++++ $name PASSED"
 244             }
 245         }
 246     } else {
 247         print_verbose $name $description $script $code $result
 248         puts stdout "---- Result should have been:"
 249         puts stdout "$answer"
 250         puts stdout "---- $name FAILED"
 251     }
 252 }
 253
 254 proc dotests {file args} {
 255     global TESTS
 256     set savedTests $TESTS
 257     set TESTS $args
 258     source $file
 259     set TESTS $savedTests
 260 }
 261
 262 # If the main window isn't already mapped (e.g. because the tests are
 263 # being run automatically) , specify a precise size for it so that the
 264 # user won't have to position it manually.
 265
 266 if {![winfo ismapped .]} {
 267     wm geometry . +0+0
 268     update
 269 }
 270
 271 # The following code can be used to perform tests involving a second
 272 # process running in the background.
 273
 274 # Locate tktest executable
 275
 276 set tktest [info nameofexecutable]
 277 if {$tktest == "{}"} {
 278     set tktest {}
 279     puts "Unable to find tktest executable, skipping multiple process tests."
 280 }
 281
 282 # Create background process
 283
 284 proc setupbg {{args ""}} {
 285     global tktest fd bgData
 286     if {$tktest == ""} {
 287         error "you're not running tktest so setupbg should not have been called"
 288     }
 289     if {[info exists fd] && ($fd != "")} {
 290         cleanupbg
 291     }
 292     set fd [open "|[list $tktest -geometry +0+0 -name tktest] $args" r+]
 293     puts $fd "puts foo; flush stdout"
 294     flush $fd
 295     if {[gets $fd data] < 0} {
 296         error "unexpected EOF from \"$tktest\""
 297     }
 298     if [string compare $data foo] {
 299         error "unexpected output from background process \"$data\""
 300     }
 301     fileevent $fd readable bgReady
 302 }
 303
 304 # Send a command to the background process, catching errors and
 305 # flushing I/O channels
 306 proc dobg {command} {
 307     global fd bgData bgDone
 308     puts $fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
 309     flush $fd
 310     set bgDone 0
 311     set bgData {}
 312     tkwait variable bgDone
 313     set bgData
 314 }
 315
 316 # Data arrived from background process.  Check for special marker
 317 # indicating end of data for this command, and make data available
 318 # to dobg procedure.
 319 proc bgReady {} {
 320     global fd bgData bgDone
 321     set x [gets $fd]
 322     if [eof $fd] {
 323         fileevent $fd readable {}
 324         set bgDone 1
 325     } elseif {$x == "**DONE**"} {
 326         set bgDone 1
 327     } else {
 328         append bgData $x
 329     }
 330 }
 331
 332 # Exit the background process, and close the pipes
 333 proc cleanupbg {} {
 334     global fd
 335     catch {
 336         puts $fd "exit"
 337         close $fd
 338     }
 339     set fd ""
 340 }
 341
 342 # Clean up focus after using generate event, which
 343 # can leave the window manager with the wrong impression
 344 # about who thinks they have the focus. (BW)
 345
 346 proc fixfocus {} {
 347     catch {destroy .focus}
 348     toplevel .focus
 349     wm geometry .focus +0+0
 350     entry .focus.e
 351     .focus.e insert 0 "fixfocus"
 352     pack .focus.e
 353     update
 354     focus -force .focus.e
 355     destroy .focus
 356 }
 357
 358 proc makeFile {contents name} {
 359     set fd [open $name w]
 360     fconfigure $fd -translation lf
 361     if {[string index $contents [expr [string length $contents] - 1]] == "\n"} {
 362         puts -nonewline $fd $contents
 363     } else {
 364         puts $fd $contents
 365     }
 366     close $fd
 367 }
 368
 369 proc removeFile {name} {
 370     file delete -- $name
 371 }