tcl/tests/defs.tcl

   1 # defs.tcl --
   2 #
   3 #       This file contains support code for the Tcl/Tk test suite.It is
   4 #       It is normally sourced by the individual files in the test suite
   5 #       before they run their tests.  This improved approach to testing
   6 #       was designed and initially implemented by Mary Ann May-Pumphrey
   7 #       of Sun Microsystems.
   8 #
   9 # Copyright (c) 1990-1994 The Regents of the University of California.
  10 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  11 # Copyright (c) 1998-1999 by Scriptics Corporation.
  12 # All rights reserved.
  13 #
  14 # RCS: @(#) $Id$
  15
  16 # Initialize wish shell
  17
  18 if {[info exists tk_version]} {
  19     tk appname tktest
  20     wm title . tktest
  21 } else {
  22
  23     # Ensure that we have a minimal auto_path so we don't pick up extra junk.
  24
  25     set auto_path [list [info library]]
  26 }
  27
  28 # create the "tcltest" namespace for all testing variables and procedures
  29
  30 namespace eval tcltest {
  31     set procList [list test cleanupTests dotests saveState restoreState \
  32             normalizeMsg makeFile removeFile makeDirectory removeDirectory \
  33             viewFile bytestring set_iso8859_1_locale restore_locale \
  34             safeFetch threadReap]
  35     if {[info exists tk_version]} {
  36         lappend procList setupbg dobg bgReady cleanupbg fixfocus
  37     }
  38     foreach proc $procList {
  39         namespace export $proc
  40     }
  41
  42     # ::tcltest::verbose defaults to "b"
  43
  44     variable verbose "b"
  45
  46     # match defaults to the empty list
  47
  48     variable match {}
  49
  50     # skip defaults to the empty list
  51
  52     variable skip {}
  53
  54     # Tests should not rely on the current working directory.
  55     # Files that are part of the test suite should be accessed relative to
  56     # ::tcltest::testsDir.
  57
  58     set originalDir [pwd]
  59     set tDir [file join $originalDir [file dirname [info script]]]
  60     cd $tDir
  61     variable testsDir [pwd]
  62     cd $originalDir
  63
  64     # Count the number of files tested (0 if all.tcl wasn't called).
  65     # The all.tcl file will set testSingleFile to false, so stats will
  66     # not be printed until all.tcl calls the cleanupTests proc.
  67     # The currentFailure var stores the boolean value of whether the
  68     # current test file has had any failures.  The failFiles list
  69     # stores the names of test files that had failures.
  70
  71     variable numTestFiles 0
  72     variable testSingleFile true
  73     variable currentFailure false
  74     variable failFiles {}
  75
  76     # Tests should remove all files they create.  The test suite will
  77     # check the current working dir for files created by the tests.
  78     # ::tcltest::filesMade keeps track of such files created using the
  79     # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
  80     # ::tcltest::filesExisted stores the names of pre-existing files.
  81
  82     variable filesMade {}
  83     variable filesExisted {}
  84
  85     # ::tcltest::numTests will store test files as indices and the list
  86     # of files (that should not have been) left behind by the test files.
  87
  88     array set ::tcltest::createdNewFiles {}
  89
  90     # initialize ::tcltest::numTests array to keep track fo the number of
  91     # tests that pass, fial, and are skipped.
  92
  93     array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
  94
  95     # initialize ::tcltest::skippedBecause array to keep track of
  96     # constraints that kept tests from running
  97
  98     array set ::tcltest::skippedBecause {}
  99
 100     # tests that use thread need to know which is the main thread
 101
 102     variable ::tcltest::mainThread 1
 103     if {[info commands testthread] != {}} {
 104         set ::tcltest::mainThread [testthread names]
 105     }
 106 }
 107
 108 # If there is no "memory" command (because memory debugging isn't
 109 # enabled), generate a dummy command that does nothing.
 110
 111 if {[info commands memory] == ""} {
 112     proc memory args {}
 113 }
 114
 115 # ::tcltest::initConfig --
 116 #
 117 # Check configuration information that will determine which tests
 118 # to run.  To do this, create an array ::tcltest::testConfig.  Each
 119 # element has a 0 or 1 value.  If the element is "true" then tests
 120 # with that constraint will be run, otherwise tests with that constraint
 121 # will be skipped.  See the README file for the list of built-in
 122 # constraints defined in this procedure.
 123 #
 124 # Arguments:
 125 #       none
 126 #
 127 # Results:
 128 #       The ::tcltest::testConfig array is reset to have an index for
 129 #       each built-in test constraint.
 130
 131 proc ::tcltest::initConfig {} {
 132
 133     global tcl_platform tcl_interactive tk_version
 134
 135     catch {unset ::tcltest::testConfig}
 136
 137     # The following trace procedure makes it so that we can safely refer to
 138     # non-existent members of the ::tcltest::testConfig array without causing an
 139     # error.  Instead, reading a non-existent member will return 0.  This is
 140     # necessary because tests are allowed to use constraint "X" without ensuring
 141     # that ::tcltest::testConfig("X") is defined.
 142
 143     trace variable ::tcltest::testConfig r ::tcltest::safeFetch
 144
 145     proc ::tcltest::safeFetch {n1 n2 op} {
 146         if {($n2 != {}) && ([info exists ::tcltest::testConfig($n2)] == 0)} {
 147             set ::tcltest::testConfig($n2) 0
 148         }
 149     }
 150
 151     set ::tcltest::testConfig(unixOnly) \
 152             [expr {$tcl_platform(platform) == "unix"}]
 153     set ::tcltest::testConfig(macOnly) \
 154             [expr {$tcl_platform(platform) == "macintosh"}]
 155     set ::tcltest::testConfig(pcOnly) \
 156             [expr {$tcl_platform(platform) == "windows"}]
 157
 158     set ::tcltest::testConfig(unix) $::tcltest::testConfig(unixOnly)
 159     set ::tcltest::testConfig(mac) $::tcltest::testConfig(macOnly)
 160     set ::tcltest::testConfig(pc) $::tcltest::testConfig(pcOnly)
 161
 162     set ::tcltest::testConfig(unixOrPc) \
 163             [expr {$::tcltest::testConfig(unix) || $::tcltest::testConfig(pc)}]
 164     set ::tcltest::testConfig(macOrPc) \
 165             [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(pc)}]
 166     set ::tcltest::testConfig(macOrUnix) \
 167             [expr {$::tcltest::testConfig(mac) || $::tcltest::testConfig(unix)}]
 168
 169     set ::tcltest::testConfig(nt) [expr {$tcl_platform(os) == "Windows NT"}]
 170     set ::tcltest::testConfig(95) [expr {$tcl_platform(os) == "Windows 95"}]
 171
 172     # The following config switches are used to mark tests that should work,
 173     # but have been temporarily disabled on certain platforms because they don't
 174     # and we haven't gotten around to fixing the underlying problem.
 175
 176     set ::tcltest::testConfig(tempNotPc) [expr {!$::tcltest::testConfig(pc)}]
 177     set ::tcltest::testConfig(tempNotMac) [expr {!$::tcltest::testConfig(mac)}]
 178     set ::tcltest::testConfig(tempNotUnix) [expr {!$::tcltest::testConfig(unix)}]
 179
 180     # The following config switches are used to mark tests that crash on
 181     # certain platforms, so that they can be reactivated again when the
 182     # underlying problem is fixed.
 183
 184     set ::tcltest::testConfig(pcCrash) [expr {!$::tcltest::testConfig(pc)}]
 185     set ::tcltest::testConfig(macCrash) [expr {!$::tcltest::testConfig(mac)}]
 186     set ::tcltest::testConfig(unixCrash) [expr {!$::tcltest::testConfig(unix)}]
 187
 188     # Set the "fonts" constraint for wish apps
 189
 190     if {[info exists tk_version]} {
 191         set ::tcltest::testConfig(fonts) 1
 192         catch {destroy .e}
 193         entry .e -width 0 -font {Helvetica -12} -bd 1
 194         .e insert end "a.bcd"
 195         if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
 196             set ::tcltest::testConfig(fonts) 0
 197         }
 198         destroy .e
 199         catch {destroy .t}
 200         text .t -width 80 -height 20 -font {Times -14} -bd 1
 201         pack .t
 202         .t insert end "This is\na dot."
 203         update
 204         set x [list [.t bbox 1.3] [.t bbox 2.5]]
 205         destroy .t
 206         if {[string match {{22 3 6 15} {31 18 [34] 15}} $x] == 0} {
 207             set ::tcltest::testConfig(fonts) 0
 208         }
 209     }
 210
 211     # Skip empty tests
 212
 213     set ::tcltest::testConfig(emptyTest) 0
 214
 215     # By default, tests that expost known bugs are skipped.
 216
 217     set ::tcltest::testConfig(knownBug) 0
 218
 219     # By default, non-portable tests are skipped.
 220
 221     set ::tcltest::testConfig(nonPortable) 0
 222
 223     # Some tests require user interaction.
 224
 225     set ::tcltest::testConfig(userInteraction) 0
 226
 227     # Some tests must be skipped if the interpreter is not in interactive mode
 228
 229     set ::tcltest::testConfig(interactive) $tcl_interactive
 230
 231     # Some tests must be skipped if you are running as root on Unix.
 232     # Other tests can only be run if you are running as root on Unix.
 233
 234     set ::tcltest::testConfig(root) 0
 235     set ::tcltest::testConfig(notRoot) 1
 236     set user {}
 237     if {$tcl_platform(platform) == "unix"} {
 238         catch {set user [exec whoami]}
 239         if {$user == ""} {
 240             catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
 241         }
 242         if {($user == "root") || ($user == "")} {
 243             set ::tcltest::testConfig(root) 1
 244             set ::tcltest::testConfig(notRoot) 0
 245         }
 246     }
 247
 248     # Set nonBlockFiles constraint: 1 means this platform supports
 249     # setting files into nonblocking mode.
 250
 251     if {[catch {set f [open defs r]}]} {
 252         set ::tcltest::testConfig(nonBlockFiles) 1
 253     } else {
 254         if {[catch {fconfigure $f -blocking off}] == 0} {
 255             set ::tcltest::testConfig(nonBlockFiles) 1
 256         } else {
 257             set ::tcltest::testConfig(nonBlockFiles) 0
 258         }
 259         close $f
 260     }
 261
 262     # Set asyncPipeClose constraint: 1 means this platform supports
 263     # async flush and async close on a pipe.
 264     #
 265     # Test for SCO Unix - cannot run async flushing tests because a
 266     # potential problem with select is apparently interfering.
 267     # (Mark Diekhans).
 268
 269     if {$tcl_platform(platform) == "unix"} {
 270         if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
 271             set ::tcltest::testConfig(asyncPipeClose) 0
 272         } else {
 273             set ::tcltest::testConfig(asyncPipeClose) 1
 274         }
 275     } else {
 276         set ::tcltest::testConfig(asyncPipeClose) 1
 277     }
 278
 279     # Test to see if we have a broken version of sprintf with respect
 280     # to the "e" format of floating-point numbers.
 281
 282     set ::tcltest::testConfig(eformat) 1
 283     if {[string compare "[format %g 5e-5]" "5e-05"] != 0} {
 284         set ::tcltest::testConfig(eformat) 0
 285     }
 286
 287     # Test to see if execed commands such as cat, echo, rm and so forth are
 288     # present on this machine.
 289
 290     set ::tcltest::testConfig(unixExecs) 1
 291     if {$tcl_platform(platform) == "macintosh"} {
 292         set ::tcltest::testConfig(unixExecs) 0
 293     }
 294     if {($::tcltest::testConfig(unixExecs) == 1) && \
 295             ($tcl_platform(platform) == "windows")} {
 296         if {[catch {exec cat defs}] == 1} {
 297             set ::tcltest::testConfig(unixExecs) 0
 298         }
 299         if {($::tcltest::testConfig(unixExecs) == 1) && \
 300                 ([catch {exec echo hello}] == 1)} {
 301             set ::tcltest::testConfig(unixExecs) 0
 302         }
 303         if {($::tcltest::testConfig(unixExecs) == 1) && \
 304                 ([catch {exec sh -c echo hello}] == 1)} {
 305             set ::tcltest::testConfig(unixExecs) 0
 306         }
 307         if {($::tcltest::testConfig(unixExecs) == 1) && \
 308                 ([catch {exec wc defs}] == 1)} {
 309             set ::tcltest::testConfig(unixExecs) 0
 310         }
 311         if {$::tcltest::testConfig(unixExecs) == 1} {
 312             exec echo hello > removeMe
 313             if {[catch {exec rm removeMe}] == 1} {
 314                 set ::tcltest::testConfig(unixExecs) 0
 315             }
 316         }
 317         if {($::tcltest::testConfig(unixExecs) == 1) && \
 318                 ([catch {exec sleep 1}] == 1)} {
 319             set ::tcltest::testConfig(unixExecs) 0
 320         }
 321         if {($::tcltest::testConfig(unixExecs) == 1) && \
 322                 ([catch {exec fgrep unixExecs defs}] == 1)} {
 323             set ::tcltest::testConfig(unixExecs) 0
 324         }
 325         if {($::tcltest::testConfig(unixExecs) == 1) && \
 326                 ([catch {exec ps}] == 1)} {
 327             set ::tcltest::testConfig(unixExecs) 0
 328         }
 329         if {($::tcltest::testConfig(unixExecs) == 1) && \
 330                 ([catch {exec echo abc > removeMe}] == 0) && \
 331                 ([catch {exec chmod 644 removeMe}] == 1) && \
 332                 ([catch {exec rm removeMe}] == 0)} {
 333             set ::tcltest::testConfig(unixExecs) 0
 334         } else {
 335             catch {exec rm -f removeMe}
 336         }
 337         if {($::tcltest::testConfig(unixExecs) == 1) && \
 338                 ([catch {exec mkdir removeMe}] == 1)} {
 339             set ::tcltest::testConfig(unixExecs) 0
 340         } else {
 341             catch {exec rm -r removeMe}
 342         }
 343     }
 344 }
 345
 346 ::tcltest::initConfig
 347
 348
 349 # ::tcltest::processCmdLineArgs --
 350 #
 351 #       Use command line args to set the verbose, skip, and
 352 #       match variables.  This procedure must be run after
 353 #       constraints are initialized, because some constraints can be
 354 #       overridden.
 355 #
 356 # Arguments:
 357 #       none
 358 #
 359 # Results:
 360 #       ::tcltest::verbose is set to <value>
 361
 362 proc ::tcltest::processCmdLineArgs {} {
 363     global argv
 364
 365     # The "argv" var doesn't exist in some cases, so use {}
 366     # The "argv" var doesn't exist in some cases.
 367
 368     if {(![info exists argv]) || ([llength $argv] < 2)} {
 369         set flagArray {}
 370     } else {
 371         set flagArray $argv
 372     }
 373
 374     if {[catch {array set flag $flagArray}]} {
 375         puts stderr "Error:  odd number of command line args specified:"
 376         puts stderr "        $argv"
 377         exit
 378     }
 379
 380     # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
 381     # Note that -verbose cannot be abbreviated to -v in wish because it
 382     # conflicts with the wish option -visual.
 383
 384     foreach arg {-verbose -match -skip -constraints} {
 385         set abbrev [string range $arg 0 1]
 386         if {([info exists flag($abbrev)]) && \
 387                 ([lsearch -exact $flagArray $arg] < \
 388                 [lsearch -exact $flagArray $abbrev])} {
 389             set flag($arg) $flag($abbrev)
 390         }
 391     }
 392
 393     # Set ::tcltest::workingDir to [pwd].
 394     # Save the names of files that already exist in ::tcltest::workingDir.
 395
 396     set ::tcltest::workingDir [pwd]
 397     foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
 398         lappend ::tcltest::filesExisted [file tail $file]
 399     }
 400
 401     # Set ::tcltest::verbose to the arg of the -verbose flag, if given
 402
 403     if {[info exists flag(-verbose)]} {
 404         set ::tcltest::verbose $flag(-verbose)
 405     }
 406
 407     # Set ::tcltest::match to the arg of the -match flag, if given
 408
 409     if {[info exists flag(-match)]} {
 410         set ::tcltest::match $flag(-match)
 411     }
 412
 413     # Set ::tcltest::skip to the arg of the -skip flag, if given
 414
 415     if {[info exists flag(-skip)]} {
 416         set ::tcltest::skip $flag(-skip)
 417     }
 418
 419     # Use the -constraints flag, if given, to turn on constraints that are
 420     # turned off by default: userInteractive knownBug nonPortable.  This
 421     # code fragment must be run after constraints are initialized.
 422
 423     if {[info exists flag(-constraints)]} {
 424         foreach elt $flag(-constraints) {
 425             set ::tcltest::testConfig($elt) 1
 426         }
 427     }
 428 }
 429
 430 ::tcltest::processCmdLineArgs
 431
 432
 433 # ::tcltest::cleanupTests --
 434 #
 435 # Remove files and dirs created using the makeFile and makeDirectory
 436 # commands since the last time this proc was invoked.
 437 #
 438 # Print the names of the files created without the makeFile command
 439 # since the tests were invoked.
 440 #
 441 # Print the number tests (total, passed, failed, and skipped) since the
 442 # tests were invoked.
 443 #
 444
 445 proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
 446     set tail [file tail [info script]]
 447
 448     # Remove files and directories created by the :tcltest::makeFile and
 449     # ::tcltest::makeDirectory procedures.
 450     # Record the names of files in ::tcltest::workingDir that were not
 451     # pre-existing, and associate them with the test file that created them.
 452
 453     if {!$calledFromAllFile} {
 454
 455         foreach file $::tcltest::filesMade {
 456             if {[file exists $file]} {
 457                 catch {file delete -force $file}
 458             }
 459         }
 460         set currentFiles {}
 461         foreach file [glob -nocomplain [file join $::tcltest::workingDir *]] {
 462             lappend currentFiles [file tail $file]
 463         }
 464         set newFiles {}
 465         foreach file $currentFiles {
 466             if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
 467                 lappend newFiles $file
 468             }
 469         }
 470         set ::tcltest::filesExisted $currentFiles
 471         if {[llength $newFiles] > 0} {
 472             set ::tcltest::createdNewFiles($tail) $newFiles
 473         }
 474     }
 475
 476     if {$calledFromAllFile || $::tcltest::testSingleFile} {
 477
 478         # print stats
 479
 480         puts -nonewline stdout "$tail:"
 481         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
 482             puts -nonewline stdout "\t$index\t$::tcltest::numTests($index)"
 483         }
 484         puts stdout ""
 485
 486         # print number test files sourced
 487         # print names of files that ran tests which failed
 488
 489         if {$calledFromAllFile} {
 490             puts stdout "Sourced $::tcltest::numTestFiles Test Files."
 491             set ::tcltest::numTestFiles 0
 492             if {[llength $::tcltest::failFiles] > 0} {
 493                 puts stdout "Files with failing tests: $::tcltest::failFiles"
 494                 set ::tcltest::failFiles {}
 495             }
 496         }
 497
 498         # if any tests were skipped, print the constraints that kept them
 499         # from running.
 500
 501         set constraintList [array names ::tcltest::skippedBecause]
 502         if {[llength $constraintList] > 0} {
 503             puts stdout "Number of tests skipped for each constraint:"
 504             foreach constraint [lsort $constraintList] {
 505                 puts stdout \
 506                         "\t$::tcltest::skippedBecause($constraint)\t$constraint"
 507                 unset ::tcltest::skippedBecause($constraint)
 508             }
 509         }
 510
 511         # report the names of test files in ::tcltest::createdNewFiles, and
 512         # reset the array to be empty.
 513
 514         set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
 515         if {[llength $testFilesThatTurded] > 0} {
 516             puts stdout "Warning: test files left files behind:"
 517             foreach testFile $testFilesThatTurded {
 518                 puts "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
 519                 unset ::tcltest::createdNewFiles($testFile)
 520             }
 521         }
 522
 523         # reset filesMade, filesExisted, and numTests
 524
 525         set ::tcltest::filesMade {}
 526         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
 527             set ::tcltest::numTests($index) 0
 528         }
 529
 530         # exit only if running Tk in non-interactive mode
 531
 532         global tk_version tcl_interactive
 533         if {[info exists tk_version] && !$tcl_interactive} {
 534             exit
 535         }
 536     } else {
 537
 538         # if we're deferring stat-reporting until all files are sourced,
 539         # then add current file to failFile list if any tests in this file
 540         # failed
 541
 542         incr ::tcltest::numTestFiles
 543         if {($::tcltest::currentFailure) && \
 544                 ([lsearch -exact $::tcltest::failFiles $tail] == -1)} {
 545             lappend ::tcltest::failFiles $tail
 546         }
 547         set ::tcltest::currentFailure false
 548     }
 549 }
 550
 551
 552 # test --
 553 #
 554 # This procedure runs a test and prints an error message if the test fails.
 555 # If ::tcltest::verbose has been set, it also prints a message even if the
 556 # test succeeds.  The test will be skipped if it doesn't match the
 557 # ::tcltest::match variable, if it matches an element in
 558 # ::tcltest::skip, or if one of the elements of "constraints" turns
 559 # out not to be true.
 560 #
 561 # Arguments:
 562 # name -                Name of test, in the form foo-1.2.
 563 # description -         Short textual description of the test, to
 564 #                       help humans understand what it does.
 565 # constraints -         A list of one or more keywords, each of
 566 #                       which must be the name of an element in
 567 #                       the array "::tcltest::testConfig".  If any of these
 568 #                       elements is zero, the test is skipped.
 569 #                       This argument may be omitted.
 570 # script -              Script to run to carry out the test.  It must
 571 #                       return a result that can be checked for
 572 #                       correctness.
 573 # expectedAnswer -      Expected result from script.
 574
 575 proc ::tcltest::test {name description script expectedAnswer args} {
 576     incr ::tcltest::numTests(Total)
 577
 578     # skip the test if it's name matches an element of skip
 579
 580     foreach pattern $::tcltest::skip {
 581         if {[string match $pattern $name]} {
 582             incr ::tcltest::numTests(Skipped)
 583             return
 584         }
 585     }
 586     # skip the test if it's name doesn't match any element of match
 587
 588     if {[llength $::tcltest::match] > 0} {
 589         set ok 0
 590         foreach pattern $::tcltest::match {
 591             if {[string match $pattern $name]} {
 592                 set ok 1
 593                 break
 594             }
 595         }
 596         if {!$ok} {
 597             incr ::tcltest::numTests(Skipped)
 598             return
 599         }
 600     }
 601     set i [llength $args]
 602     if {$i == 0} {
 603         set constraints {}
 604     } elseif {$i == 1} {
 605
 606         # "constraints" argument exists;  shuffle arguments down, then
 607         # make sure that the constraints are satisfied.
 608
 609         set constraints $script
 610         set script $expectedAnswer
 611         set expectedAnswer [lindex $args 0]
 612         set doTest 0
 613         if {[string match {*[$\[]*} $constraints] != 0} {
 614
 615             # full expression, e.g. {$foo > [info tclversion]}
 616
 617             catch {set doTest [uplevel #0 expr $constraints]}
 618
 619         } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
 620
 621             # something like {a || b} should be turned into
 622             # $::tcltest::testConfig(a) || $::tcltest::testConfig(b).
 623
 624             regsub -all {[.a-zA-Z0-9]+} $constraints \
 625                     {$::tcltest::testConfig(&)} c
 626             catch {set doTest [eval expr $c]}
 627         } else {
 628
 629             # just simple constraints such as {unixOnly fonts}.
 630
 631             set doTest 1
 632             foreach constraint $constraints {
 633                 if {![info exists ::tcltest::testConfig($constraint)]
 634                         || !$::tcltest::testConfig($constraint)} {
 635                     set doTest 0
 636
 637                     # store the constraint that kept the test from running
 638
 639                     set constraints $constraint
 640                     break
 641                 }
 642             }
 643         }
 644         if {$doTest == 0} {
 645             incr ::tcltest::numTests(Skipped)
 646             if {[string first s $::tcltest::verbose] != -1} {
 647                 puts stdout "++++ $name SKIPPED: $constraints"
 648             }
 649
 650             # add the constraint to the list of constraints the kept tests
 651             # from running
 652
 653             if {[info exists ::tcltest::skippedBecause($constraints)]} {
 654                 incr ::tcltest::skippedBecause($constraints)
 655             } else {
 656                 set ::tcltest::skippedBecause($constraints) 1
 657             }
 658             return
 659         }
 660     } else {
 661         error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
 662     }
 663     memory tag $name
 664     set code [catch {uplevel $script} actualAnswer]
 665     if {$code != 0 || [string compare $actualAnswer $expectedAnswer] != 0} {
 666         incr ::tcltest::numTests(Failed)
 667         set ::tcltest::currentFailure true
 668         if {[string first b $::tcltest::verbose] == -1} {
 669             set script ""
 670         }
 671         puts stdout "\n==== $name $description FAILED"
 672         if {$script != ""} {
 673             puts stdout "==== Contents of test case:"
 674             puts stdout $script
 675         }
 676         if {$code != 0} {
 677             if {$code == 1} {
 678                 puts stdout "==== Test generated error:"
 679                 puts stdout $actualAnswer
 680             } elseif {$code == 2} {
 681                 puts stdout "==== Test generated return exception;  result was:"
 682                 puts stdout $actualAnswer
 683             } elseif {$code == 3} {
 684                 puts stdout "==== Test generated break exception"
 685             } elseif {$code == 4} {
 686                 puts stdout "==== Test generated continue exception"
 687             } else {
 688                 puts stdout "==== Test generated exception $code;  message was:"
 689                 puts stdout $actualAnswer
 690             }
 691         } else {
 692             puts stdout "---- Result was:\n$actualAnswer"
 693         }
 694         puts stdout "---- Result should have been:\n$expectedAnswer"
 695         puts stdout "==== $name FAILED\n"
 696     } else {
 697         incr ::tcltest::numTests(Passed)
 698         if {[string first p $::tcltest::verbose] != -1} {
 699             puts stdout "++++ $name PASSED"
 700         }
 701     }
 702 }
 703
 704 # ::tcltest::dotests --
 705 #
 706 #       takes two arguments--the name of the test file (such
 707 #       as "parse.test"), and a pattern selecting the tests you want to
 708 #       execute.  It sets ::tcltest::matching to the second argument, calls
 709 #       "source" on the file specified in the first argument, and restores
 710 #       ::tcltest::matching to its pre-call value at the end.
 711 #
 712 # Arguments:
 713 #       file    name of tests file to source
 714 #       args    pattern selecting the tests you want to execute
 715 #
 716 # Results:
 717 #       none
 718
 719 proc ::tcltest::dotests {file args} {
 720     set savedTests $::tcltest::match
 721     set ::tcltest::match $args
 722     source $file
 723     set ::tcltest::match $savedTests
 724 }
 725
 726 proc ::tcltest::openfiles {} {
 727     if {[catch {testchannel open} result]} {
 728         return {}
 729     }
 730     return $result
 731 }
 732
 733 proc ::tcltest::leakfiles {old} {
 734     if {[catch {testchannel open} new]} {
 735         return {}
 736     }
 737     set leak {}
 738     foreach p $new {
 739         if {[lsearch $old $p] < 0} {
 740             lappend leak $p
 741         }
 742     }
 743     return $leak
 744 }
 745
 746 set ::tcltest::saveState {}
 747
 748 proc ::tcltest::saveState {} {
 749     uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
 750 }
 751
 752 proc ::tcltest::restoreState {} {
 753     foreach p [info procs] {
 754         if {[lsearch [lindex $::tcltest::saveState 0] $p] < 0} {
 755             rename $p {}
 756         }
 757     }
 758     foreach p [uplevel #0 {info vars}] {
 759         if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
 760             uplevel #0 "unset $p"
 761         }
 762     }
 763 }
 764
 765 proc ::tcltest::normalizeMsg {msg} {
 766     regsub "\n$" [string tolower $msg] "" msg
 767     regsub -all "\n\n" $msg "\n" msg
 768     regsub -all "\n\}" $msg "\}" msg
 769     return $msg
 770 }
 771
 772 # makeFile --
 773 #
 774 # Create a new file with the name <name>, and write <contents> to it.
 775 #
 776 # If this file hasn't been created via makeFile since the last time
 777 # cleanupTests was called, add it to the $filesMade list, so it will
 778 # be removed by the next call to cleanupTests.
 779 #
 780 proc ::tcltest::makeFile {contents name} {
 781     set fd [open $name w]
 782     fconfigure $fd -translation lf
 783     if {[string index $contents [expr {[string length $contents] - 1}]] == "\n"} {
 784         puts -nonewline $fd $contents
 785     } else {
 786         puts $fd $contents
 787     }
 788     close $fd
 789
 790     set fullName [file join [pwd] $name]
 791     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
 792         lappend ::tcltest::filesMade $fullName
 793     }
 794 }
 795
 796 proc ::tcltest::removeFile {name} {
 797     file delete $name
 798 }
 799
 800 # makeDirectory --
 801 #
 802 # Create a new dir with the name <name>.
 803 #
 804 # If this dir hasn't been created via makeDirectory since the last time
 805 # cleanupTests was called, add it to the $directoriesMade list, so it will
 806 # be removed by the next call to cleanupTests.
 807 #
 808 proc ::tcltest::makeDirectory {name} {
 809     file mkdir $name
 810
 811     set fullName [file join [pwd] $name]
 812     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
 813         lappend ::tcltest::filesMade $fullName
 814     }
 815 }
 816
 817 proc ::tcltest::removeDirectory {name} {
 818     file delete -force $name
 819 }
 820
 821 proc ::tcltest::viewFile {name} {
 822     global tcl_platform
 823     if {($tcl_platform(platform) == "macintosh") || \
 824                 ($::tcltest::testConfig(unixExecs) == 0)} {
 825         set f [open $name]
 826         set data [read -nonewline $f]
 827         close $f
 828         return $data
 829     } else {
 830         exec cat $name
 831     }
 832 }
 833
 834 #
 835 # Construct a string that consists of the requested sequence of bytes,
 836 # as opposed to a string of properly formed UTF-8 characters.
 837 # This allows the tester to
 838 # 1. Create denormalized or improperly formed strings to pass to C procedures
 839 #    that are supposed to accept strings with embedded NULL bytes.
 840 # 2. Confirm that a string result has a certain pattern of bytes, for instance
 841 #    to confirm that "\xe0\0" in a Tcl script is stored internally in
 842 #    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
 843 #
 844 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
 845 # construct improperly formed strings in this manner, because it involves
 846 # exposing that Tcl uses UTF-8 internally.
 847
 848 proc ::tcltest::bytestring {string} {
 849     encoding convertfrom identity $string
 850 }
 851
 852 # Locate tcltest executable
 853
 854 if {![info exists tk_version]} {
 855     set tcltest [info nameofexecutable]
 856
 857     if {$tcltest == "{}"} {
 858         set tcltest {}
 859     }
 860 }
 861
 862 set ::tcltest::testConfig(stdio) 0
 863 catch {
 864     catch {file delete -force tmp}
 865     set f [open tmp w]
 866     puts $f {
 867         exit
 868     }
 869     close $f
 870
 871     set f [open "|[list $tcltest tmp]" r]
 872     close $f
 873
 874     set ::tcltest::testConfig(stdio) 1
 875 }
 876 catch {file delete -force tmp}
 877
 878 # Deliberately call the socket with the wrong number of arguments.  The error
 879 # message you get will indicate whether sockets are available on this system.
 880
 881 catch {socket} msg
 882 set ::tcltest::testConfig(socket) \
 883         [expr {$msg != "sockets are not available on this system"}]
 884
 885 #
 886 # Internationalization / ISO support procs     -- dl
 887 #
 888
 889 if {[info commands testlocale]==""} {
 890
 891     # No testlocale command, no tests...
 892     # (it could be that we are a sub interp and we could just load
 893     # the Tcltest package but that would interfere with tests
 894     # that tests packages/loading in slaves...)
 895
 896     set ::tcltest::testConfig(hasIsoLocale) 0
 897 } else {
 898     proc ::tcltest::set_iso8859_1_locale {} {
 899         set ::tcltest::previousLocale [testlocale ctype]
 900         testlocale ctype $::tcltest::isoLocale
 901     }
 902
 903     proc ::tcltest::restore_locale {} {
 904         testlocale ctype $::tcltest::previousLocale
 905     }
 906
 907     if {![info exists ::tcltest::isoLocale]} {
 908         set ::tcltest::isoLocale fr
 909         switch $tcl_platform(platform) {
 910             "unix" {
 911
 912                 # Try some 'known' values for some platforms:
 913
 914                 switch -exact -- $tcl_platform(os) {
 915                     "FreeBSD" {
 916                         set ::tcltest::isoLocale fr_FR.ISO_8859-1
 917                     }
 918                     HP-UX {
 919                         set ::tcltest::isoLocale fr_FR.iso88591
 920                     }
 921                     Linux -
 922                     IRIX {
 923                         set ::tcltest::isoLocale fr
 924                     }
 925                     default {
 926
 927                         # Works on SunOS 4 and Solaris, and maybe others...
 928                         # define it to something else on your system
 929                         #if you want to test those.
 930
 931                         set ::tcltest::isoLocale iso_8859_1
 932                     }
 933                 }
 934             }
 935             "windows" {
 936                 set ::tcltest::isoLocale French
 937             }
 938         }
 939     }
 940
 941     set ::tcltest::testConfig(hasIsoLocale) \
 942             [string length [::tcltest::set_iso8859_1_locale]]
 943     ::tcltest::restore_locale
 944 }
 945
 946 #
 947 # procedures that are Tk specific
 948 #
 949
 950 if {[info exists tk_version]} {
 951
 952     # If the main window isn't already mapped (e.g. because the tests are
 953     # being run automatically) , specify a precise size for it so that the
 954     # user won't have to position it manually.
 955
 956     if {![winfo ismapped .]} {
 957         wm geometry . +0+0
 958         update
 959     }
 960
 961     # The following code can be used to perform tests involving a second
 962     # process running in the background.
 963
 964     # Locate the tktest executable
 965
 966     set ::tcltest::tktest [info nameofexecutable]
 967     if {$::tcltest::tktest == "{}"} {
 968         set ::tcltest::tktest {}
 969         puts stdout \
 970                 "Unable to find tktest executable, skipping multiple process tests."
 971     }
 972
 973     # Create background process
 974
 975     proc ::tcltest::setupbg args {
 976         if {$::tcltest::tktest == ""} {
 977             error "you're not running tktest so setupbg should not have been called"
 978         }
 979         if {[info exists ::tcltest::fd] && ($::tcltest::fd != "")} {
 980             cleanupbg
 981         }
 982
 983         # The following code segment cannot be run on Windows in Tk8.1b2
 984         # This bug is logged as a pipe bug (bugID 1495).
 985
 986         global tcl_platform
 987         if {$tcl_platform(platform) != "windows"} {
 988             set ::tcltest::fd [open "|[list $::tcltest::tktest -geometry +0+0 -name tktest] $args" r+]
 989             puts $::tcltest::fd "puts foo; flush stdout"
 990             flush $::tcltest::fd
 991             if {[gets $::tcltest::fd data] < 0} {
 992                 error "unexpected EOF from \"$::tcltest::tktest\""
 993             }
 994             if {[string compare $data foo]} {
 995                 error "unexpected output from background process \"$data\""
 996             }
 997             fileevent $::tcltest::fd readable bgReady
 998         }
 999     }
1000
1001     # Send a command to the background process, catching errors and
1002     # flushing I/O channels
1003
1004     proc ::tcltest::dobg {command} {
1005         puts $::tcltest::fd "catch [list $command] msg; update; puts \$msg; puts **DONE**; flush stdout"
1006         flush $::tcltest::fd
1007         set ::tcltest::bgDone 0
1008         set ::tcltest::bgData {}
1009         tkwait variable ::tcltest::bgDone
1010         set ::tcltest::bgData
1011     }
1012
1013     # Data arrived from background process.  Check for special marker
1014     # indicating end of data for this command, and make data available
1015     # to dobg procedure.
1016
1017     proc ::tcltest::bgReady {} {
1018         set x [gets $::tcltest::fd]
1019         if {[eof $::tcltest::fd]} {
1020             fileevent $::tcltest::fd readable {}
1021             set ::tcltest::bgDone 1
1022         } elseif {$x == "**DONE**"} {
1023             set ::tcltest::bgDone 1
1024         } else {
1025             append ::tcltest::bgData $x
1026         }
1027     }
1028
1029     # Exit the background process, and close the pipes
1030
1031     proc ::tcltest::cleanupbg {} {
1032         catch {
1033             puts $::tcltest::fd "exit"
1034             close $::tcltest::fd
1035         }
1036         set ::tcltest::fd ""
1037     }
1038
1039     # Clean up focus after using generate event, which
1040     # can leave the window manager with the wrong impression
1041     # about who thinks they have the focus. (BW)
1042
1043     proc ::tcltest::fixfocus {} {
1044         catch {destroy .focus}
1045         toplevel .focus
1046         wm geometry .focus +0+0
1047         entry .focus.e
1048         .focus.e insert 0 "fixfocus"
1049         pack .focus.e
1050         update
1051         focus -force .focus.e
1052         destroy .focus
1053     }
1054 }
1055
1056 # threadReap --
1057 #
1058 #       Kill all threads except for the main thread.
1059 #       Do nothing if testthread is not defined.
1060 #
1061 # Arguments:
1062 #       none.
1063 #
1064 # Results:
1065 #       Returns the number of existing threads.
1066
1067 if {[info commands testthread] != {}} {
1068     proc ::tcltest::threadReap {} {
1069         testthread errorproc ThreadNullError
1070         while {[llength [testthread names]] > 1} {
1071             foreach tid [testthread names] {
1072                 if {$tid != $::tcltest::mainThread} {
1073                     catch {testthread send -async $tid {testthread exit}}
1074                     update
1075                 }
1076             }
1077         }
1078         testthread errorproc ThreadError
1079         return [llength [testthread names]]
1080     }
1081 } else {
1082     proc ::tcltest::threadReap {} {
1083         return 1
1084     }
1085 }
1086
1087 # Need to catch the import because it fails if defs.tcl is sourced
1088 # more than once.
1089
1090 catch {namespace import ::tcltest::*}
1091 return