tcl/library/tcltest1.0/tcltest.tcl

   1 # tcltest.tcl --
   2 #
   3 #       This file contains support code for the Tcl test suite.  It
   4 #       defines the ::tcltest namespace and finds and defines the output
   5 #       directory, constraints available, output and error channels, etc. used
   6 #       by Tcl tests.  See the tcltest man page for more details.
   7 #
   8 #       This design was based on the Tcl testing approach designed and
   9 #       initially implemented by Mary Ann May-Pumphrey of Sun Microsystems.
  10 #
  11 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  12 # Copyright (c) 1998-1999 by Scriptics Corporation.
  13 # All rights reserved.
  14 #
  15 # RCS: @(#) $Id$
  16
  17 package provide tcltest 1.0
  18
  19 # create the "tcltest" namespace for all testing variables and procedures
  20
  21 namespace eval tcltest {
  22
  23     # Export the public tcltest procs
  24     set procList [list test cleanupTests saveState restoreState \
  25             normalizeMsg makeFile removeFile makeDirectory removeDirectory \
  26             viewFile bytestring safeFetch threadReap getMatchingFiles \
  27             loadTestedCommands normalizePath]
  28     foreach proc $procList {
  29         namespace export $proc
  30     }
  31
  32     # ::tcltest::verbose defaults to "b"
  33     if {![info exists verbose]} {
  34         variable verbose "b"
  35     }
  36
  37     # Match and skip patterns default to the empty list, except for
  38     # matchFiles, which defaults to all .test files in the testsDirectory
  39
  40     if {![info exists match]} {
  41         variable match {}
  42     }
  43     if {![info exists skip]} {
  44         variable skip {}
  45     }
  46     if {![info exists matchFiles]} {
  47         variable matchFiles {*.test}
  48     }
  49     if {![info exists skipFiles]} {
  50         variable skipFiles {}
  51     }
  52
  53     # By default, don't save core files
  54     if {![info exists preserveCore]} {
  55         variable preserveCore 0
  56     }
  57
  58     # output goes to stdout by default
  59     if {![info exists outputChannel]} {
  60         variable outputChannel stdout
  61     }
  62
  63     # errors go to stderr by default
  64     if {![info exists errorChannel]} {
  65         variable errorChannel stderr
  66     }
  67
  68     # debug output doesn't get printed by default; debug level 1 spits
  69     # up only the tests that were skipped because they didn't match or were
  70     # specifically skipped.  A debug level of 2 would spit up the tcltest
  71     # variables and flags provided; a debug level of 3 causes some additional
  72     # output regarding operations of the test harness.  The tcltest package
  73     # currently implements only up to debug level 3.
  74     if {![info exists debug]} {
  75         variable debug 0
  76     }
  77
  78     # Save any arguments that we might want to pass through to other programs.
  79     # This is used by the -args flag.
  80     if {![info exists parameters]} {
  81         variable parameters {}
  82     }
  83
  84     # Count the number of files tested (0 if all.tcl wasn't called).
  85     # The all.tcl file will set testSingleFile to false, so stats will
  86     # not be printed until all.tcl calls the cleanupTests proc.
  87     # The currentFailure var stores the boolean value of whether the
  88     # current test file has had any failures.  The failFiles list
  89     # stores the names of test files that had failures.
  90
  91     if {![info exists numTestFiles]} {
  92         variable numTestFiles 0
  93     }
  94     if {![info exists testSingleFile]} {
  95         variable testSingleFile true
  96     }
  97     if {![info exists currentFailure]} {
  98         variable currentFailure false
  99     }
 100     if {![info exists failFiles]} {
 101         variable failFiles {}
 102     }
 103
 104     # Tests should remove all files they create.  The test suite will
 105     # check the current working dir for files created by the tests.
 106     # ::tcltest::filesMade keeps track of such files created using the
 107     # ::tcltest::makeFile and ::tcltest::makeDirectory procedures.
 108     # ::tcltest::filesExisted stores the names of pre-existing files.
 109
 110     if {![info exists filesMade]} {
 111         variable filesMade {}
 112     }
 113     if {![info exists filesExisted]} {
 114         variable filesExisted {}
 115     }
 116
 117     # ::tcltest::numTests will store test files as indices and the list
 118     # of files (that should not have been) left behind by the test files.
 119
 120     if {![info exists createdNewFiles]} {
 121         variable createdNewFiles
 122         array set ::tcltest::createdNewFiles {}
 123     }
 124
 125     # initialize ::tcltest::numTests array to keep track fo the number of
 126     # tests that pass, fail, and are skipped.
 127
 128     if {![info exists numTests]} {
 129         variable numTests
 130         array set ::tcltest::numTests \
 131                 [list Total 0 Passed 0 Skipped 0 Failed 0]
 132     }
 133
 134     # initialize ::tcltest::skippedBecause array to keep track of
 135     # constraints that kept tests from running; a constraint name of
 136     # "userSpecifiedSkip" means that the test appeared on the list of tests
 137     # that matched the -skip value given to the flag; "userSpecifiedNonMatch"
 138     # means that the test didn't match the argument given to the -match flag;
 139     # both of these constraints are counted only if ::tcltest::debug is set to
 140     # true.
 141
 142     if {![info exists skippedBecause]} {
 143         variable skippedBecause
 144         array set ::tcltest::skippedBecause {}
 145     }
 146
 147     # initialize the ::tcltest::testConstraints array to keep track of valid
 148     # predefined constraints (see the explanation for the
 149     # ::tcltest::initConstraints proc for more details).
 150
 151     if {![info exists testConstraints]} {
 152         variable testConstraints
 153         array set ::tcltest::testConstraints {}
 154     }
 155
 156     # Don't run only the constrained tests by default
 157
 158     if {![info exists limitConstraints]} {
 159         variable limitConstraints false
 160     }
 161
 162     # A test application has to know how to load the tested commands into
 163     # the interpreter.
 164
 165     if {![info exists loadScript]} {
 166         variable loadScript {}
 167     }
 168
 169     # tests that use threads need to know which is the main thread
 170
 171     if {![info exists mainThread]} {
 172         variable mainThread 1
 173         if {[info commands thread::id] != {}} {
 174             set mainThread [thread::id]
 175         } elseif {[info commands testthread] != {}} {
 176             set mainThread [testthread id]
 177         }
 178     }
 179
 180     # save the original environment so that it can be restored later
 181
 182     if {![info exists originalEnv]} {
 183         variable originalEnv
 184         array set ::tcltest::originalEnv [array get ::env]
 185     }
 186
 187     # Set ::tcltest::workingDirectory to [pwd]. The default output directory
 188     # for Tcl tests is the working directory.
 189
 190     if {![info exists workingDirectory]} {
 191         variable workingDirectory [pwd]
 192     }
 193     if {![info exists temporaryDirectory]} {
 194         variable temporaryDirectory $workingDirectory
 195     }
 196
 197     # Tests should not rely on the current working directory.
 198     # Files that are part of the test suite should be accessed relative to
 199     # ::tcltest::testsDirectory.
 200
 201     if {![info exists testsDirectory]} {
 202         set oldpwd [pwd]
 203         catch {cd [file join [file dirname [info script]] .. .. tests]}
 204         variable testsDirectory [pwd]
 205         cd $oldpwd
 206         unset oldpwd
 207     }
 208
 209     # the variables and procs that existed when ::tcltest::saveState was
 210     # called are stored in a variable of the same name
 211     if {![info exists saveState]} {
 212         variable saveState {}
 213     }
 214
 215     # Internationalization support
 216     if {![info exists isoLocale]} {
 217         variable isoLocale fr
 218         switch $tcl_platform(platform) {
 219             "unix" {
 220
 221                 # Try some 'known' values for some platforms:
 222
 223                 switch -exact -- $tcl_platform(os) {
 224                     "FreeBSD" {
 225                         set ::tcltest::isoLocale fr_FR.ISO_8859-1
 226                     }
 227                     HP-UX {
 228                         set ::tcltest::isoLocale fr_FR.iso88591
 229                     }
 230                     Linux -
 231                     IRIX {
 232                         set ::tcltest::isoLocale fr
 233                     }
 234                     default {
 235
 236                         # Works on SunOS 4 and Solaris, and maybe others...
 237                         # define it to something else on your system
 238                         #if you want to test those.
 239
 240                         set ::tcltest::isoLocale iso_8859_1
 241                     }
 242                 }
 243             }
 244             "windows" {
 245                 set ::tcltest::isoLocale French
 246             }
 247         }
 248     }
 249
 250     # Set the location of the execuatble
 251     if {![info exists tcltest]} {
 252         variable tcltest [info nameofexecutable]
 253     }
 254
 255     # save the platform information so it can be restored later
 256     if {![info exists originalTclPlatform]} {
 257         variable originalTclPlatform [array get tcl_platform]
 258     }
 259
 260     # If a core file exists, save its modification time.
 261     if {![info exists coreModificationTime]} {
 262         if {[file exists [file join $::tcltest::workingDirectory core]]} {
 263             variable coreModificationTime [file mtime [file join \
 264                     $::tcltest::workingDirectory core]]
 265         }
 266     }
 267
 268     # Tcl version numbers
 269     if {![info exists version]} {
 270         variable version 8.3
 271     }
 272     if {![info exists patchLevel]} {
 273         variable patchLevel 8.3.0
 274     }
 275 }
 276
 277 # ::tcltest::Debug* --
 278 #
 279 #     Internal helper procedures to write out debug information
 280 #     dependent on the chosen level. A test shell may overide
 281 #     them, f.e. to redirect the output into a different
 282 #     channel, or even into a GUI.
 283
 284 # ::tcltest::DebugPuts --
 285 #
 286 #     Prints the specified string if the current debug level is
 287 #     higher than the provided level argument.
 288 #
 289 # Arguments:
 290 #     level   The lowest debug level triggering the output
 291 #     string  The string to print out.
 292 #
 293 # Results:
 294 #     Prints the string. Nothing else is allowed.
 295 #
 296
 297 proc ::tcltest::DebugPuts {level string} {
 298     variable debug
 299     if {$debug >= $level} {
 300         puts $string
 301     }
 302 }
 303
 304 # ::tcltest::DebugPArray --
 305 #
 306 #     Prints the contents of the specified array if the current
 307 #       debug level is higher than the provided level argument
 308 #
 309 # Arguments:
 310 #     level           The lowest debug level triggering the output
 311 #     arrayvar        The name of the array to print out.
 312 #
 313 # Results:
 314 #     Prints the contents of the array. Nothing else is allowed.
 315 #
 316
 317 proc ::tcltest::DebugPArray {level arrayvar} {
 318     variable debug
 319
 320     if {$debug >= $level} {
 321         catch {upvar  $arrayvar $arrayvar}
 322         parray $arrayvar
 323     }
 324 }
 325
 326 # ::tcltest::DebugDo --
 327 #
 328 #     Executes the script if the current debug level is greater than
 329 #       the provided level argument
 330 #
 331 # Arguments:
 332 #     level   The lowest debug level triggering the execution.
 333 #     script  The tcl script executed upon a debug level high enough.
 334 #
 335 # Results:
 336 #     Arbitrary side effects, dependent on the executed script.
 337 #
 338
 339 proc ::tcltest::DebugDo {level script} {
 340     variable debug
 341
 342     if {$debug >= $level} {
 343         uplevel $script
 344     }
 345 }
 346
 347 # ::tcltest::AddToSkippedBecause --
 348 #
 349 #       Increments the variable used to track how many tests were skipped
 350 #       because of a particular constraint.
 351 #
 352 # Arguments:
 353 #       constraint     The name of the constraint to be modified
 354 #
 355 # Results:
 356 #       Modifies ::tcltest::skippedBecause; sets the variable to 1 if didn't
 357 #       previously exist - otherwise, it just increments it.
 358
 359 proc ::tcltest::AddToSkippedBecause { constraint } {
 360     # add the constraint to the list of constraints that kept tests
 361     # from running
 362
 363     if {[info exists ::tcltest::skippedBecause($constraint)]} {
 364         incr ::tcltest::skippedBecause($constraint)
 365     } else {
 366         set ::tcltest::skippedBecause($constraint) 1
 367     }
 368     return
 369 }
 370
 371 # ::tcltest::PrintError --
 372 #
 373 #       Prints errors to ::tcltest::errorChannel and then flushes that
 374 #       channel, making sure that all messages are < 80 characters per line.
 375 #
 376 # Arguments:
 377 #       errorMsg     String containing the error to be printed
 378 #
 379
 380 proc ::tcltest::PrintError {errorMsg} {
 381     set InitialMessage "Error:  "
 382     set InitialMsgLen  [string length $InitialMessage]
 383     puts -nonewline $::tcltest::errorChannel $InitialMessage
 384
 385     # Keep track of where the end of the string is.
 386     set endingIndex [string length $errorMsg]
 387
 388     if {$endingIndex < 80} {
 389         puts $::tcltest::errorChannel $errorMsg
 390     } else {
 391         # Print up to 80 characters on the first line, including the
 392         # InitialMessage.
 393         set beginningIndex [string last " " [string range $errorMsg 0 \
 394                 [expr {80 - $InitialMsgLen}]]]
 395         puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex]
 396
 397         while {$beginningIndex != "end"} {
 398             puts -nonewline $::tcltest::errorChannel \
 399                     [string repeat " " $InitialMsgLen]
 400             if {[expr {$endingIndex - $beginningIndex}] < 72} {
 401                 puts $::tcltest::errorChannel [string trim \
 402                         [string range $errorMsg $beginningIndex end]]
 403                 set beginningIndex end
 404             } else {
 405                 set newEndingIndex [expr [string last " " [string range \
 406                         $errorMsg $beginningIndex \
 407                         [expr {$beginningIndex + 72}]]] + $beginningIndex]
 408                 if {($newEndingIndex <= 0) \
 409                         || ($newEndingIndex <= $beginningIndex)} {
 410                     set newEndingIndex end
 411                 }
 412                 puts $::tcltest::errorChannel [string trim \
 413                         [string range $errorMsg \
 414                         $beginningIndex $newEndingIndex]]
 415                 set beginningIndex $newEndingIndex
 416             }
 417         }
 418     }
 419     flush $::tcltest::errorChannel
 420     return
 421 }
 422
 423 if {[namespace inscope ::tcltest info procs initConstraintsHook] == {}} {
 424     proc ::tcltest::initConstraintsHook {} {}
 425 }
 426
 427 # ::tcltest::initConstraints --
 428 #
 429 # Check Constraintsuration information that will determine which tests
 430 # to run.  To do this, create an array ::tcltest::testConstraints.  Each
 431 # element has a 0 or 1 value.  If the element is "true" then tests
 432 # with that constraint will be run, otherwise tests with that constraint
 433 # will be skipped.  See the tcltest man page for the list of built-in
 434 # constraints defined in this procedure.
 435 #
 436 # Arguments:
 437 #       none
 438 #
 439 # Results:
 440 #       The ::tcltest::testConstraints array is reset to have an index for
 441 #       each built-in test constraint.
 442
 443 proc ::tcltest::initConstraints {} {
 444     global tcl_platform tcl_interactive tk_version
 445
 446     # The following trace procedure makes it so that we can safely refer to
 447     # non-existent members of the ::tcltest::testConstraints array without
 448     # causing an error.  Instead, reading a non-existent member will return 0.
 449     # This is necessary because tests are allowed to use constraint "X" without
 450     # ensuring that ::tcltest::testConstraints("X") is defined.
 451
 452     trace variable ::tcltest::testConstraints r ::tcltest::safeFetch
 453
 454     proc ::tcltest::safeFetch {n1 n2 op} {
 455         if {($n2 != {}) && ([info exists ::tcltest::testConstraints($n2)] == 0)} {
 456             set ::tcltest::testConstraints($n2) 0
 457         }
 458     }
 459
 460     ::tcltest::initConstraintsHook
 461
 462     set ::tcltest::testConstraints(unixOnly) \
 463             [string equal $tcl_platform(platform) "unix"]
 464     set ::tcltest::testConstraints(macOnly) \
 465             [string equal $tcl_platform(platform) "macintosh"]
 466     set ::tcltest::testConstraints(pcOnly) \
 467             [string equal $tcl_platform(platform) "windows"]
 468
 469     set ::tcltest::testConstraints(unix) $::tcltest::testConstraints(unixOnly)
 470     set ::tcltest::testConstraints(mac) $::tcltest::testConstraints(macOnly)
 471     set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly)
 472
 473     set ::tcltest::testConstraints(unixOrPc) \
 474             [expr {$::tcltest::testConstraints(unix) \
 475             || $::tcltest::testConstraints(pc)}]
 476     set ::tcltest::testConstraints(macOrPc) \
 477             [expr {$::tcltest::testConstraints(mac) \
 478             || $::tcltest::testConstraints(pc)}]
 479     set ::tcltest::testConstraints(macOrUnix) \
 480             [expr {$::tcltest::testConstraints(mac) \
 481             || $::tcltest::testConstraints(unix)}]
 482
 483     set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \
 484             "Windows NT"]
 485     set ::tcltest::testConstraints(95) [string equal $tcl_platform(os) \
 486             "Windows 95"]
 487     set ::tcltest::testConstraints(98) [string equal $tcl_platform(os) \
 488             "Windows 98"]
 489
 490     # The following Constraints switches are used to mark tests that should
 491     # work, but have been temporarily disabled on certain platforms because
 492     # they don't and we haven't gotten around to fixing the underlying
 493     # problem.
 494
 495     set ::tcltest::testConstraints(tempNotPc) \
 496             [expr {!$::tcltest::testConstraints(pc)}]
 497     set ::tcltest::testConstraints(tempNotMac) \
 498             [expr {!$::tcltest::testConstraints(mac)}]
 499     set ::tcltest::testConstraints(tempNotUnix) \
 500             [expr {!$::tcltest::testConstraints(unix)}]
 501
 502     # The following Constraints switches are used to mark tests that crash on
 503     # certain platforms, so that they can be reactivated again when the
 504     # underlying problem is fixed.
 505
 506     set ::tcltest::testConstraints(pcCrash) \
 507             [expr {!$::tcltest::testConstraints(pc)}]
 508     set ::tcltest::testConstraints(macCrash) \
 509             [expr {!$::tcltest::testConstraints(mac)}]
 510     set ::tcltest::testConstraints(unixCrash) \
 511             [expr {!$::tcltest::testConstraints(unix)}]
 512
 513     # Skip empty tests
 514
 515     set ::tcltest::testConstraints(emptyTest) 0
 516
 517     # By default, tests that expose known bugs are skipped.
 518
 519     set ::tcltest::testConstraints(knownBug) 0
 520
 521     # By default, non-portable tests are skipped.
 522
 523     set ::tcltest::testConstraints(nonPortable) 0
 524
 525     # Some tests require user interaction.
 526
 527     set ::tcltest::testConstraints(userInteraction) 0
 528
 529     # Some tests must be skipped if the interpreter is not in interactive mode
 530
 531     if {[info exists tcl_interactive]} {
 532         set ::tcltest::testConstraints(interactive) $::tcl_interactive
 533     } else {
 534         set ::tcltest::testConstraints(interactive) 0
 535     }
 536
 537     # Some tests can only be run if the installation came from a CD image
 538     # instead of a web image
 539     # Some tests must be skipped if you are running as root on Unix.
 540     # Other tests can only be run if you are running as root on Unix.
 541
 542     set ::tcltest::testConstraints(root) 0
 543     set ::tcltest::testConstraints(notRoot) 1
 544     set user {}
 545     if {[string equal $tcl_platform(platform) "unix"]} {
 546         catch {set user [exec whoami]}
 547         if {[string equal $user ""]} {
 548             catch {regexp {^[^(]*\(([^)]*)\)} [exec id] dummy user}
 549         }
 550         if {([string equal $user "root"]) || ([string equal $user ""])} {
 551             set ::tcltest::testConstraints(root) 1
 552             set ::tcltest::testConstraints(notRoot) 0
 553         }
 554     }
 555
 556     # Set nonBlockFiles constraint: 1 means this platform supports
 557     # setting files into nonblocking mode.
 558
 559     if {[catch {set f [open defs r]}]} {
 560         set ::tcltest::testConstraints(nonBlockFiles) 1
 561     } else {
 562         if {[catch {fconfigure $f -blocking off}] == 0} {
 563             set ::tcltest::testConstraints(nonBlockFiles) 1
 564         } else {
 565             set ::tcltest::testConstraints(nonBlockFiles) 0
 566         }
 567         close $f
 568     }
 569
 570     # Set asyncPipeClose constraint: 1 means this platform supports
 571     # async flush and async close on a pipe.
 572     #
 573     # Test for SCO Unix - cannot run async flushing tests because a
 574     # potential problem with select is apparently interfering.
 575     # (Mark Diekhans).
 576
 577     if {[string equal $tcl_platform(platform) "unix"]} {
 578         if {[catch {exec uname -X | fgrep {Release = 3.2v}}] == 0} {
 579             set ::tcltest::testConstraints(asyncPipeClose) 0
 580         } else {
 581             set ::tcltest::testConstraints(asyncPipeClose) 1
 582         }
 583     } else {
 584         set ::tcltest::testConstraints(asyncPipeClose) 1
 585     }
 586
 587     # Test to see if we have a broken version of sprintf with respect
 588     # to the "e" format of floating-point numbers.
 589
 590     set ::tcltest::testConstraints(eformat) 1
 591     if {![string equal "[format %g 5e-5]" "5e-05"]} {
 592         set ::tcltest::testConstraints(eformat) 0
 593     }
 594
 595     # Test to see if execed commands such as cat, echo, rm and so forth are
 596     # present on this machine.
 597
 598     set ::tcltest::testConstraints(unixExecs) 1
 599     if {[string equal $tcl_platform(platform) "macintosh"]} {
 600         set ::tcltest::testConstraints(unixExecs) 0
 601     }
 602     if {($::tcltest::testConstraints(unixExecs) == 1) && \
 603             ([string equal $tcl_platform(platform) "windows"])} {
 604         if {[catch {exec cat defs}] == 1} {
 605             set ::tcltest::testConstraints(unixExecs) 0
 606         }
 607         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 608                 ([catch {exec echo hello}] == 1)} {
 609             set ::tcltest::testConstraints(unixExecs) 0
 610         }
 611         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 612                 ([catch {exec sh -c echo hello}] == 1)} {
 613             set ::tcltest::testConstraints(unixExecs) 0
 614         }
 615         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 616                 ([catch {exec wc defs}] == 1)} {
 617             set ::tcltest::testConstraints(unixExecs) 0
 618         }
 619         if {$::tcltest::testConstraints(unixExecs) == 1} {
 620             exec echo hello > removeMe
 621             if {[catch {exec rm removeMe}] == 1} {
 622                 set ::tcltest::testConstraints(unixExecs) 0
 623             }
 624         }
 625         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 626                 ([catch {exec sleep 1}] == 1)} {
 627             set ::tcltest::testConstraints(unixExecs) 0
 628         }
 629         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 630                 ([catch {exec fgrep unixExecs defs}] == 1)} {
 631             set ::tcltest::testConstraints(unixExecs) 0
 632         }
 633         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 634                 ([catch {exec ps}] == 1)} {
 635             set ::tcltest::testConstraints(unixExecs) 0
 636         }
 637         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 638                 ([catch {exec echo abc > removeMe}] == 0) && \
 639                 ([catch {exec chmod 644 removeMe}] == 1) && \
 640                 ([catch {exec rm removeMe}] == 0)} {
 641             set ::tcltest::testConstraints(unixExecs) 0
 642         } else {
 643             catch {exec rm -f removeMe}
 644         }
 645         if {($::tcltest::testConstraints(unixExecs) == 1) && \
 646                 ([catch {exec mkdir removeMe}] == 1)} {
 647             set ::tcltest::testConstraints(unixExecs) 0
 648         } else {
 649             catch {exec rm -r removeMe}
 650         }
 651     }
 652
 653     # Locate tcltest executable
 654
 655     if {![info exists tk_version]} {
 656         set tcltest [info nameofexecutable]
 657
 658         if {$tcltest == "{}"} {
 659             set tcltest {}
 660         }
 661     }
 662
 663     set ::tcltest::testConstraints(stdio) 0
 664     catch {
 665         catch {file delete -force tmp}
 666         set f [open tmp w]
 667         puts $f {
 668             exit
 669         }
 670         close $f
 671
 672         set f [open "|[list $tcltest tmp]" r]
 673         close $f
 674
 675         set ::tcltest::testConstraints(stdio) 1
 676     }
 677     catch {file delete -force tmp}
 678
 679     # Deliberately call socket with the wrong number of arguments.  The error
 680     # message you get will indicate whether sockets are available on this
 681     # system.
 682
 683     catch {socket} msg
 684     set ::tcltest::testConstraints(socket) \
 685             [expr {$msg != "sockets are not available on this system"}]
 686
 687     # Check for internationalization
 688
 689     if {[info commands testlocale] == ""} {
 690         # No testlocale command, no tests...
 691         set ::tcltest::testConstraints(hasIsoLocale) 0
 692     } else {
 693         set ::tcltest::testConstraints(hasIsoLocale) \
 694                 [string length [::tcltest::set_iso8859_1_locale]]
 695         ::tcltest::restore_locale
 696     }
 697 }
 698
 699 # ::tcltest::PrintUsageInfoHook
 700 #
 701 #       Hook used for customization of display of usage information.
 702 #
 703
 704 if {[namespace inscope ::tcltest info procs PrintUsageInfoHook] == {}} {
 705     proc ::tcltest::PrintUsageInfoHook {} {}
 706 }
 707
 708 # ::tcltest::PrintUsageInfo
 709 #
 710 #       Prints out the usage information for package tcltest.  This can be
 711 #       customized with the redefinition of ::tcltest::PrintUsageInfoHook.
 712 #
 713 # Arguments:
 714 #       none
 715 #
 716
 717 proc ::tcltest::PrintUsageInfo {} {
 718     puts [format "Usage: [file tail [info nameofexecutable]] \
 719             script ?-help? ?flag value? ... \n\
 720             Available flags (and valid input values) are: \n\
 721             -help          \t Display this usage information. \n\
 722             -verbose level \t Takes any combination of the values \n\
 723             \t                 'p', 's' and 'b'.  Test suite will \n\
 724             \t                 display all passed tests if 'p' is \n\
 725             \t                 specified, all skipped tests if 's' \n\
 726             \t                 is specified, and the bodies of \n\
 727             \t                 failed tests if 'b' is specified. \n\
 728             \t                 The default value is 'b'. \n\
 729             -constraints list\t Do not skip the listed constraints\n\
 730             -limitconstraints bool\t Only run tests with the constraints\n\
 731             \t                 listed in -constraints.\n\
 732             -match pattern \t Run all tests within the specified \n\
 733             \t                 files that match the glob pattern \n\
 734             \t                 given. \n\
 735             -skip pattern  \t Skip all tests within the set of \n\
 736             \t                 specified tests (via -match) and \n\
 737             \t                 files that match the glob pattern \n\
 738             \t                 given. \n\
 739             -file pattern  \t Run tests in all test files that \n\
 740             \t                 match the glob pattern given. \n\
 741             -notfile pattern\t Skip all test files that match the \n\
 742             \t                 glob pattern given. \n\
 743             -preservecore level \t If 2, save any core files produced \n\
 744             \t                 during testing in the directory \n\
 745             \t                 specified by -tmpdir. If 1, notify the\n\
 746             \t                 user if core files are created. The default \n\
 747             \t                 is $::tcltest::preserveCore. \n\
 748             -tmpdir directory\t Save temporary files in the specified\n\
 749             \t                 directory.  The default value is \n\
 750             \t                 $::tcltest::temporaryDirectory. \n\
 751             -testdir directories\t Search tests in the specified\n\
 752             \t                 directories.  The default value is \n\
 753             \t                 $::tcltest::testsDirectory. \n\
 754             -outfile file    \t Send output from test runs to the \n\
 755             \t                 specified file.  The default is \n\
 756             \t                 stdout. \n\
 757             -errfile file    \t Send errors from test runs to the \n\
 758             \t                 specified file.  The default is \n\
 759             \t                 stderr. \n\
 760             -loadfile file   \t Read the script to load the tested \n\
 761             \t                 commands from the specified file. \n\
 762             -load script     \t Specifies the script to load the tested \n\
 763             \t                 commands. \n\
 764             -debug level     \t Internal debug flag."]
 765     ::tcltest::PrintUsageInfoHook
 766     return
 767 }
 768
 769 # ::tcltest::CheckDirectory --
 770 #
 771 #     This procedure checks whether the specified path is a readable
 772 #     and/or writable directory. If one of the conditions is not
 773 #     satisfied an error is printed and the application aborted. The
 774 #     procedure assumes that the caller already checked the existence
 775 #     of the path.
 776 #
 777 # Arguments
 778 #     rw      Information what attributes to check. Allowed values:
 779 #             r, w, rw, wr. If 'r' is part of the value the directory
 780 #             must be readable. 'w' associates to 'writable'.
 781 #     dir     The directory to check.
 782 #     errMsg  The string to prepend to the actual error message before
 783 #             printing it.
 784 #
 785 # Results
 786 #     none
 787 #
 788
 789 proc ::tcltest::CheckDirectory {rw dir errMsg} {
 790     # Allowed values for 'rw': r, w, rw, wr
 791
 792     if {![file isdir $dir]} {
 793         ::tcltest::PrintError "$errMsg \"$dir\" is not a directory"
 794         exit 1
 795     } elseif {([string first w $rw] >= 0) && ![file writable $dir]} {
 796         ::tcltest::PrintError "$errMsg \"$dir\" is not writeable"
 797         exit 1
 798     } elseif {([string first r $rw] >= 0) && ![file readable $dir]} {
 799         ::tcltest::PrintError "$errMsg \"$dir\" is not readable"
 800         exit 1
 801     }
 802 }
 803
 804 # ::tcltest::normalizePath --
 805 #
 806 #     This procedure resolves any symlinks in the path thus creating a
 807 #     path without internal redirection. It assumes that the incoming
 808 #     path is absolute.
 809 #
 810 # Arguments
 811 #     pathVar contains the name of the variable containing the path to modify.
 812 #
 813 # Results
 814 #     The path is modified in place.
 815 #
 816
 817 proc ::tcltest::normalizePath {pathVar} {
 818     upvar $pathVar path
 819
 820     set oldpwd [pwd]
 821     catch {cd $path}
 822     set path [pwd]
 823     cd $oldpwd
 824 }
 825
 826 # ::tcltest::MakeAbsolutePath --
 827 #
 828 #     This procedure checks whether the incoming path is absolute or not.
 829 #     Makes it absolute if it was not.
 830 #
 831 # Arguments
 832 #     pathVar contains the name of the variable containing the path to modify.
 833 #     prefix  is optional, contains the path to use to make the other an
 834 #             absolute one. The current working directory is used if it was
 835 #             not specified.
 836 #
 837 # Results
 838 #     The path is modified in place.
 839 #
 840
 841 proc ::tcltest::MakeAbsolutePath {pathVar {prefix {}}} {
 842     upvar $pathVar path
 843
 844     if {![string equal [file pathtype $path] "absolute"]} {
 845         if {$prefix == {}} {
 846             set prefix [pwd]
 847         }
 848
 849         set path [file join $prefix $path]
 850     }
 851 }
 852
 853 # ::tcltest::processCmdLineArgsFlagsHook --
 854 #
 855 #       This hook is used to add to the list of command line arguments that are
 856 #       processed by ::tcltest::processCmdLineArgs.
 857 #
 858
 859 if {[namespace inscope ::tcltest info procs processCmdLineArgsAddFlagsHook] == {}} {
 860     proc ::tcltest::processCmdLineArgsAddFlagsHook {} {}
 861 }
 862
 863 # ::tcltest::processCmdLineArgsHook --
 864 #
 865 #       This hook is used to actually process the flags added by
 866 #       ::tcltest::processCmdLineArgsAddFlagsHook.
 867 #
 868 # Arguments:
 869 #       flags      The flags that have been pulled out of argv
 870 #
 871
 872 if {[namespace inscope ::tcltest info procs processCmdLineArgsHook] == {}} {
 873     proc ::tcltest::processCmdLineArgsHook {flag} {}
 874 }
 875
 876 # ::tcltest::processCmdLineArgs --
 877 #
 878 #       Use command line args to set the verbose, skip, and
 879 #       match, outputChannel, errorChannel, debug, and temporaryDirectory
 880 #       variables.
 881 #
 882 #       This procedure must be run after constraints are initialized, because
 883 #       some constraints can be overridden.
 884 #
 885 # Arguments:
 886 #       none
 887 #
 888 # Results:
 889 #       Sets the above-named variables in the tcltest namespace.
 890
 891 proc ::tcltest::processCmdLineArgs {} {
 892     global argv
 893
 894     # The "argv" var doesn't exist in some cases, so use {}.
 895
 896     if {(![info exists argv]) || ([llength $argv] < 1)} {
 897         set flagArray {}
 898     } else {
 899         set flagArray $argv
 900     }
 901
 902     # Allow for 1-char abbreviations, where applicable (e.g., -match == -m).
 903     # Note that -verbose cannot be abbreviated to -v in wish because it
 904     # conflicts with the wish option -visual.
 905
 906     # Process -help first
 907     if {([lsearch -exact $flagArray {-help}] != -1) || \
 908             ([lsearch -exact $flagArray {-h}] != -1)} {
 909         ::tcltest::PrintUsageInfo
 910         exit 1
 911     }
 912
 913     if {[catch {array set flag $flagArray}]} {
 914         ::tcltest::PrintError "odd number of arguments specified on command line: \
 915         $argv"
 916         ::tcltest::PrintUsageInfo
 917         exit 1
 918     }
 919
 920     # -help is not listed since it has already been processed
 921     lappend defaultFlags -verbose -match -skip -constraints \
 922             -outfile -errfile -debug -tmpdir -file -notfile \
 923             -preservecore -limitconstraints -args -testdir \
 924             -load -loadfile
 925     set defaultFlags [concat $defaultFlags \
 926             [ ::tcltest::processCmdLineArgsAddFlagsHook ]]
 927
 928     foreach arg $defaultFlags {
 929         set abbrev [string range $arg 0 1]
 930         if {([info exists flag($abbrev)]) && \
 931                 ([lsearch -exact $flagArray $arg] < [lsearch -exact \
 932                 $flagArray $abbrev])} {
 933             set flag($arg) $flag($abbrev)
 934         }
 935     }
 936
 937     # Set ::tcltest::parameters to the arg of the -args flag, if given
 938     if {[info exists flag(-args)]} {
 939         set ::tcltest::parameters $flag(-args)
 940     }
 941
 942     # Set ::tcltest::verbose to the arg of the -verbose flag, if given
 943
 944     if {[info exists flag(-verbose)]} {
 945         set ::tcltest::verbose $flag(-verbose)
 946     }
 947
 948     # Set ::tcltest::match to the arg of the -match flag, if given.
 949
 950     if {[info exists flag(-match)]} {
 951         set ::tcltest::match $flag(-match)
 952     }
 953
 954     # Set ::tcltest::skip to the arg of the -skip flag, if given
 955
 956     if {[info exists flag(-skip)]} {
 957         set ::tcltest::skip $flag(-skip)
 958     }
 959
 960     # Handle the -file and -notfile flags
 961     if {[info exists flag(-file)]} {
 962         set ::tcltest::matchFiles $flag(-file)
 963     }
 964     if {[info exists flag(-notfile)]} {
 965         set ::tcltest::skipFiles $flag(-notfile)
 966     }
 967
 968     # Use the -constraints flag, if given, to turn on constraints that are
 969     # turned off by default: userInteractive knownBug nonPortable.  This
 970     # code fragment must be run after constraints are initialized.
 971
 972     if {[info exists flag(-constraints)]} {
 973         foreach elt $flag(-constraints) {
 974             set ::tcltest::testConstraints($elt) 1
 975         }
 976     }
 977
 978     # Use the -limitconstraints flag, if given, to tell the harness to limit
 979     # tests run to those that were specified using the -constraints flag.  If
 980     # the -constraints flag was not specified, print out an error and exit.
 981     if {[info exists flag(-limitconstraints)]} {
 982         if {![info exists flag(-constraints)]} {
 983             puts "You can only use the -limitconstraints flag with \
 984                     -constraints"
 985             exit 1
 986         }
 987         set ::tcltest::limitConstraints $flag(-limitconstraints)
 988         foreach elt [array names ::tcltest::testConstraints] {
 989             if {[lsearch -exact $flag(-constraints) $elt] == -1} {
 990                 set ::tcltest::testConstraints($elt) 0
 991             }
 992         }
 993     }
 994
 995     # Set the ::tcltest::temporaryDirectory to the arg of -tmpdir, if
 996     # given.
 997     #
 998     # If the path is relative, make it absolute.  If the file exists but
 999     # is not a dir, then return an error.
1000     #
1001     # If ::tcltest::temporaryDirectory does not already exist, create it.
1002     # If you cannot create it, then return an error.
1003
1004     set tmpDirError ""
1005     if {[info exists flag(-tmpdir)]} {
1006         set ::tcltest::temporaryDirectory $flag(-tmpdir)
1007
1008         MakeAbsolutePath ::tcltest::temporaryDirectory
1009         set tmpDirError "bad argument \"$flag(-tmpdir)\" to -tmpdir: "
1010     }
1011     if {[file exists $::tcltest::temporaryDirectory]} {
1012         ::tcltest::CheckDirectory rw $::tcltest::temporaryDirectory $tmpDirError
1013     } else {
1014         file mkdir $::tcltest::temporaryDirectory
1015     }
1016
1017     normalizePath ::tcltest::temporaryDirectory
1018
1019     # Set the ::tcltest::testsDirectory to the arg of -testdir, if
1020     # given.
1021     #
1022     # If the path is relative, make it absolute.  If the file exists but
1023     # is not a dir, then return an error.
1024     #
1025     # If ::tcltest::temporaryDirectory does not already exist return an error.
1026
1027     set testDirError ""
1028     if {[info exists flag(-testdir)]} {
1029         set ::tcltest::testsDirectory $flag(-testdir)
1030
1031         MakeAbsolutePath ::tcltest::testsDirectory
1032         set testDirError "bad argument \"$flag(-testdir)\" to -testdir: "
1033     }
1034     if {[file exists $::tcltest::testsDirectory]} {
1035         ::tcltest::CheckDirectory r $::tcltest::testsDirectory $testDirError
1036     } else {
1037         ::tcltest::PrintError "$testDirError \"$::tcltest::testsDirectory\" \
1038                 does not exist"
1039         exit 1
1040     }
1041
1042     normalizePath ::tcltest::testsDirectory
1043
1044     # Save the names of files that already exist in
1045     # the output directory.
1046     foreach file [glob -nocomplain \
1047             [file join $::tcltest::temporaryDirectory *]] {
1048         lappend ::tcltest::filesExisted [file tail $file]
1049     }
1050
1051     # If an alternate error or output files are specified, change the
1052     # default channels.
1053
1054     if {[info exists flag(-outfile)]} {
1055         set tmp $flag(-outfile)
1056         MakeAbsolutePath tmp $::tcltest::temporaryDirectory
1057         set ::tcltest::outputChannel [open $tmp w]
1058     }
1059
1060     if {[info exists flag(-errfile)]} {
1061         set tmp $flag(-errfile)
1062         MakeAbsolutePath tmp $::tcltest::temporaryDirectory
1063         set ::tcltest::errorChannel [open $tmp w]
1064     }
1065
1066     # If a load script was specified, either directly or through
1067     # a file, remember it for later usage.
1068
1069     if {[info exists flag(-load)] &&  \
1070             ([lsearch -exact $flagArray -load] > \
1071             [lsearch -exact $flagArray -loadfile])} {
1072             set ::tcltest::loadScript $flag(-load)
1073     }
1074
1075     if {[info exists flag(-loadfile)] && \
1076             ([lsearch -exact $flagArray -loadfile] > \
1077             [lsearch -exact $flagArray -load]) } {
1078         set tmp $flag(-loadfile)
1079         MakeAbsolutePath tmp $::tcltest::temporaryDirectory
1080         set tmp [open $tmp r]
1081         set ::tcltest::loadScript [read $tmp]
1082         close $tmp
1083     }
1084
1085     # If the user specifies debug testing, print out extra information during
1086     # the run.
1087     if {[info exists flag(-debug)]} {
1088         set ::tcltest::debug $flag(-debug)
1089     }
1090
1091     # Handle -preservecore
1092     if {[info exists flag(-preservecore)]} {
1093         set ::tcltest::preserveCore $flag(-preservecore)
1094     }
1095
1096     # Call the hook
1097     ::tcltest::processCmdLineArgsHook [array get flag]
1098
1099     # Spit out everything you know if we're at a debug level 2 or greater
1100
1101     DebugPuts    2 "Flags passed into tcltest:"
1102     DebugPArray  2 flag
1103     DebugPuts    2 "::tcltest::debug              = $::tcltest::debug"
1104     DebugPuts    2 "::tcltest::testsDirectory     = $::tcltest::testsDirectory"
1105     DebugPuts    2 "::tcltest::workingDirectory   = $::tcltest::workingDirectory"
1106     DebugPuts    2 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
1107     DebugPuts    2 "::tcltest::outputChannel      = $::tcltest::outputChannel"
1108     DebugPuts    2 "::tcltest::errorChannel       = $::tcltest::errorChannel"
1109     DebugPuts    2 "Original environment (::tcltest::originalEnv):"
1110     DebugPArray  2 ::tcltest::originalEnv
1111     DebugPuts    2 "Constraints:"
1112     DebugPArray  2 ::tcltest::testConstraints
1113 }
1114
1115 # ::tcltest::loadTestedCommands --
1116 #
1117 #     Uses the specified script to load the commands to test. Allowed to
1118 #     be empty, as the tested commands could have been compiled into the
1119 #     interpreter.
1120 #
1121 # Arguments
1122 #     none
1123 #
1124 # Results
1125 #     none
1126
1127 proc ::tcltest::loadTestedCommands {} {
1128     if {$::tcltest::loadScript == {}} {
1129         return
1130     }
1131
1132     uplevel #0 $::tcltest::loadScript
1133 }
1134
1135 # ::tcltest::cleanupTests --
1136 #
1137 # Remove files and dirs created using the makeFile and makeDirectory
1138 # commands since the last time this proc was invoked.
1139 #
1140 # Print the names of the files created without the makeFile command
1141 # since the tests were invoked.
1142 #
1143 # Print the number tests (total, passed, failed, and skipped) since the
1144 # tests were invoked.
1145 #
1146 # Restore original environment (as reported by special variable env).
1147
1148 proc ::tcltest::cleanupTests {{calledFromAllFile 0}} {
1149
1150     set testFileName [file tail [info script]]
1151
1152     # Call the cleanup hook
1153     ::tcltest::cleanupTestsHook
1154
1155     # Remove files and directories created by the :tcltest::makeFile and
1156     # ::tcltest::makeDirectory procedures.
1157     # Record the names of files in ::tcltest::workingDirectory that were not
1158     # pre-existing, and associate them with the test file that created them.
1159
1160     if {!$calledFromAllFile} {
1161         foreach file $::tcltest::filesMade {
1162             if {[file exists $file]} {
1163                 catch {file delete -force $file}
1164             }
1165         }
1166         set currentFiles {}
1167         foreach file [glob -nocomplain \
1168                 [file join $::tcltest::temporaryDirectory *]] {
1169             lappend currentFiles [file tail $file]
1170         }
1171         set newFiles {}
1172         foreach file $currentFiles {
1173             if {[lsearch -exact $::tcltest::filesExisted $file] == -1} {
1174                 lappend newFiles $file
1175             }
1176         }
1177         set ::tcltest::filesExisted $currentFiles
1178         if {[llength $newFiles] > 0} {
1179             set ::tcltest::createdNewFiles($testFileName) $newFiles
1180         }
1181     }
1182
1183     if {$calledFromAllFile || $::tcltest::testSingleFile} {
1184
1185         # print stats
1186
1187         puts -nonewline $::tcltest::outputChannel "$testFileName:"
1188         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
1189             puts -nonewline $::tcltest::outputChannel \
1190                     "\t$index\t$::tcltest::numTests($index)"
1191         }
1192         puts $::tcltest::outputChannel ""
1193
1194         # print number test files sourced
1195         # print names of files that ran tests which failed
1196
1197         if {$calledFromAllFile} {
1198             puts $::tcltest::outputChannel \
1199                     "Sourced $::tcltest::numTestFiles Test Files."
1200             set ::tcltest::numTestFiles 0
1201             if {[llength $::tcltest::failFiles] > 0} {
1202                 puts $::tcltest::outputChannel \
1203                         "Files with failing tests: $::tcltest::failFiles"
1204                 set ::tcltest::failFiles {}
1205             }
1206         }
1207
1208         # if any tests were skipped, print the constraints that kept them
1209         # from running.
1210
1211         set constraintList [array names ::tcltest::skippedBecause]
1212         if {[llength $constraintList] > 0} {
1213             puts $::tcltest::outputChannel \
1214                     "Number of tests skipped for each constraint:"
1215             foreach constraint [lsort $constraintList] {
1216                 puts $::tcltest::outputChannel \
1217                         "\t$::tcltest::skippedBecause($constraint)\t$constraint"
1218                 unset ::tcltest::skippedBecause($constraint)
1219             }
1220         }
1221
1222         # report the names of test files in ::tcltest::createdNewFiles, and
1223         # reset the array to be empty.
1224
1225         set testFilesThatTurded [lsort [array names ::tcltest::createdNewFiles]]
1226         if {[llength $testFilesThatTurded] > 0} {
1227             puts $::tcltest::outputChannel "Warning: files left behind:"
1228             foreach testFile $testFilesThatTurded {
1229                 puts $::tcltest::outputChannel \
1230                         "\t$testFile:\t$::tcltest::createdNewFiles($testFile)"
1231                 unset ::tcltest::createdNewFiles($testFile)
1232             }
1233         }
1234
1235         # reset filesMade, filesExisted, and numTests
1236
1237         set ::tcltest::filesMade {}
1238         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
1239             set ::tcltest::numTests($index) 0
1240         }
1241
1242         # exit only if running Tk in non-interactive mode
1243
1244         global tk_version tcl_interactive
1245         if {[info exists tk_version] && ![info exists tcl_interactive]} {
1246             exit
1247         }
1248     } else {
1249
1250         # if we're deferring stat-reporting until all files are sourced,
1251         # then add current file to failFile list if any tests in this file
1252         # failed
1253
1254         incr ::tcltest::numTestFiles
1255         if {($::tcltest::currentFailure) && \
1256                 ([lsearch -exact $::tcltest::failFiles $testFileName] == -1)} {
1257             lappend ::tcltest::failFiles $testFileName
1258         }
1259         set ::tcltest::currentFailure false
1260
1261         # restore the environment to the state it was in before this package
1262         # was loaded
1263
1264         set newEnv {}
1265         set changedEnv {}
1266         set removedEnv {}
1267         foreach index [array names ::env] {
1268             if {![info exists ::tcltest::originalEnv($index)]} {
1269                 lappend newEnv $index
1270                 unset ::env($index)
1271             } else {
1272                 if {$::env($index) != $::tcltest::originalEnv($index)} {
1273                     lappend changedEnv $index
1274                     set ::env($index) $::tcltest::originalEnv($index)
1275                 }
1276             }
1277         }
1278         foreach index [array names ::tcltest::originalEnv] {
1279             if {![info exists ::env($index)]} {
1280                 lappend removedEnv $index
1281                 set ::env($index) $::tcltest::originalEnv($index)
1282             }
1283         }
1284         if {[llength $newEnv] > 0} {
1285             puts $::tcltest::outputChannel \
1286                     "env array elements created:\t$newEnv"
1287         }
1288         if {[llength $changedEnv] > 0} {
1289             puts $::tcltest::outputChannel \
1290                     "env array elements changed:\t$changedEnv"
1291         }
1292         if {[llength $removedEnv] > 0} {
1293             puts $::tcltest::outputChannel \
1294                     "env array elements removed:\t$removedEnv"
1295         }
1296
1297         set changedTclPlatform {}
1298         foreach index [array names ::tcltest::originalTclPlatform] {
1299             if {$::tcl_platform($index) != \
1300                     $::tcltest::originalTclPlatform($index)} {
1301                 lappend changedTclPlatform $index
1302                 set ::tcl_platform($index) \
1303                         $::tcltest::originalTclPlatform($index)
1304             }
1305         }
1306         if {[llength $changedTclPlatform] > 0} {
1307             puts $::tcltest::outputChannel \
1308                     "tcl_platform array elements changed:\t$changedTclPlatform"
1309         }
1310
1311         if {[file exists [file join $::tcltest::workingDirectory core]]} {
1312             if {$::tcltest::preserveCore > 1} {
1313                 puts $::tcltest::outputChannel "produced core file! \
1314                         Moving file to: \
1315                         [file join $::tcltest::temporaryDirectory core-$name]"
1316                 flush $::tcltest::outputChannel
1317                 catch {file rename -force \
1318                         [file join $::tcltest::workingDirectory core] \
1319                         [file join $::tcltest::temporaryDirectory \
1320                         core-$name]} msg
1321                 if {[string length $msg] > 0} {
1322                     ::tcltest::PrintError "Problem renaming file: $msg"
1323                 }
1324             } else {
1325                 # Print a message if there is a core file and (1) there
1326                 # previously wasn't one or (2) the new one is different from
1327                 # the old one.
1328
1329                 if {[info exists ::tcltest::coreModificationTime]} {
1330                     if {$::tcltest::coreModificationTime != [file mtime \
1331                             [file join $::tcltest::workingDirectory core]]} {
1332                         puts $::tcltest::outputChannel "A core file was created!"
1333                     }
1334                 } else {
1335                     puts $::tcltest::outputChannel "A core file was created!"
1336                 }
1337             }
1338         }
1339     }
1340 }
1341
1342 # ::tcltest::cleanupTestsHook --
1343 #
1344 #       This hook allows a harness that builds upon tcltest to specify
1345 #       additional things that should be done at cleanup.
1346 #
1347
1348 if {[namespace inscope ::tcltest info procs cleanupTestsHook] == {}} {
1349     proc ::tcltest::cleanupTestsHook {} {}
1350 }
1351
1352 # test --
1353 #
1354 # This procedure runs a test and prints an error message if the test fails.
1355 # If ::tcltest::verbose has been set, it also prints a message even if the
1356 # test succeeds.  The test will be skipped if it doesn't match the
1357 # ::tcltest::match variable, if it matches an element in
1358 # ::tcltest::skip, or if one of the elements of "constraints" turns
1359 # out not to be true.
1360 #
1361 # Arguments:
1362 # name -                Name of test, in the form foo-1.2.
1363 # description -         Short textual description of the test, to
1364 #                       help humans understand what it does.
1365 # constraints -         A list of one or more keywords, each of
1366 #                       which must be the name of an element in
1367 #                       the array "::tcltest::testConstraints".  If any of these
1368 #                       elements is zero, the test is skipped.
1369 #                       This argument may be omitted.
1370 # script -              Script to run to carry out the test.  It must
1371 #                       return a result that can be checked for
1372 #                       correctness.
1373 # expectedAnswer -      Expected result from script.
1374
1375 proc ::tcltest::test {name description script expectedAnswer args} {
1376
1377     DebugPuts 3 "Running $name ($description)"
1378
1379     incr ::tcltest::numTests(Total)
1380
1381     # skip the test if it's name matches an element of skip
1382
1383     foreach pattern $::tcltest::skip {
1384         if {[string match $pattern $name]} {
1385             incr ::tcltest::numTests(Skipped)
1386             DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
1387             return
1388         }
1389     }
1390
1391     # skip the test if it's name doesn't match any element of match
1392
1393     if {[llength $::tcltest::match] > 0} {
1394         set ok 0
1395         foreach pattern $::tcltest::match {
1396             if {[string match $pattern $name]} {
1397                 set ok 1
1398                 break
1399             }
1400         }
1401         if {!$ok} {
1402             incr ::tcltest::numTests(Skipped)
1403             DebugDo 1 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
1404             return
1405         }
1406     }
1407
1408     set i [llength $args]
1409     if {$i == 0} {
1410         set constraints {}
1411         # If we're limited to the listed constraints and there aren't any
1412         # listed, then we shouldn't run the test.
1413         if {$::tcltest::limitConstraints} {
1414             ::tcltest::AddToSkippedBecause userSpecifiedLimitConstraint
1415             incr ::tcltest::numTests(Skipped)
1416             return
1417         }
1418     } elseif {$i == 1} {
1419
1420         # "constraints" argument exists;  shuffle arguments down, then
1421         # make sure that the constraints are satisfied.
1422
1423         set constraints $script
1424         set script $expectedAnswer
1425         set expectedAnswer [lindex $args 0]
1426         set doTest 0
1427         if {[string match {*[$\[]*} $constraints] != 0} {
1428             # full expression, e.g. {$foo > [info tclversion]}
1429             catch {set doTest [uplevel #0 expr $constraints]}
1430         } elseif {[regexp {[^.a-zA-Z0-9 ]+} $constraints] != 0} {
1431             # something like {a || b} should be turned into
1432             # $::tcltest::testConstraints(a) || $::tcltest::testConstraints(b).
1433             regsub -all {[.\w]+} $constraints \
1434                     {$::tcltest::testConstraints(&)} c
1435             catch {set doTest [eval expr $c]}
1436         } else {
1437             # just simple constraints such as {unixOnly fonts}.
1438             set doTest 1
1439             foreach constraint $constraints {
1440                 if {(![info exists ::tcltest::testConstraints($constraint)]) \
1441                         || (!$::tcltest::testConstraints($constraint))} {
1442                     set doTest 0
1443
1444                     # store the constraint that kept the test from running
1445                     set constraints $constraint
1446                     break
1447                 }
1448             }
1449         }
1450         if {$doTest == 0} {
1451             if {[string first s $::tcltest::verbose] != -1} {
1452                 puts $::tcltest::outputChannel "++++ $name SKIPPED: $constraints"
1453             }
1454
1455             incr ::tcltest::numTests(Skipped)
1456             ::tcltest::AddToSkippedBecause $constraints
1457             return
1458         }
1459     } else {
1460         error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\""
1461     }
1462
1463     # Save information about the core file.  You need to restore the original
1464     # tcl_platform environment because some of the tests mess with tcl_platform.
1465
1466     if {$::tcltest::preserveCore} {
1467         set currentTclPlatform [array get tcl_platform]
1468         array set tcl_platform $::tcltest::originalTclPlatform
1469         if {[file exists [file join $::tcltest::workingDirectory core]]} {
1470             set coreModTime [file mtime [file join \
1471                     $::tcltest::workingDirectory core]]
1472         }
1473         array set tcl_platform $currentTclPlatform
1474     }
1475
1476     # If there is no "memory" command (because memory debugging isn't
1477     # enabled), then don't attempt to use the command.
1478
1479     if {[info commands memory] != {}} {
1480         memory tag $name
1481     }
1482
1483     set code [catch {uplevel $script} actualAnswer]
1484     if {([string equal $actualAnswer $expectedAnswer]) && ($code == 0)} {
1485         incr ::tcltest::numTests(Passed)
1486         if {[string first p $::tcltest::verbose] != -1} {
1487             puts $::tcltest::outputChannel "++++ $name PASSED"
1488         }
1489     } else {
1490         incr ::tcltest::numTests(Failed)
1491         set ::tcltest::currentFailure true
1492         if {[string first b $::tcltest::verbose] == -1} {
1493             set script ""
1494         }
1495         puts $::tcltest::outputChannel "\n==== $name $description FAILED"
1496         if {$script != ""} {
1497             puts $::tcltest::outputChannel "==== Contents of test case:"
1498             puts $::tcltest::outputChannel $script
1499         }
1500         if {$code != 0} {
1501             if {$code == 1} {
1502                 puts $::tcltest::outputChannel "==== Test generated error:"
1503                 puts $::tcltest::outputChannel $actualAnswer
1504             } elseif {$code == 2} {
1505                 puts $::tcltest::outputChannel "==== Test generated return exception;  result was:"
1506                 puts $::tcltest::outputChannel $actualAnswer
1507             } elseif {$code == 3} {
1508                 puts $::tcltest::outputChannel "==== Test generated break exception"
1509             } elseif {$code == 4} {
1510                 puts $::tcltest::outputChannel "==== Test generated continue exception"
1511             } else {
1512                 puts $::tcltest::outputChannel "==== Test generated exception $code;  message was:"
1513                 puts $::tcltest::outputChannel $actualAnswer
1514             }
1515         } else {
1516             puts $::tcltest::outputChannel "---- Result was:\n$actualAnswer"
1517         }
1518         puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer"
1519         puts $::tcltest::outputChannel "==== $name FAILED\n"
1520     }
1521     if {$::tcltest::preserveCore} {
1522         set currentTclPlatform [array get tcl_platform]
1523         if {[file exists [file join $::tcltest::workingDirectory core]]} {
1524             if {$::tcltest::preserveCore > 1} {
1525                 puts $::tcltest::outputChannel "==== $name produced core file! \
1526                         Moving file to: \
1527                         [file join $::tcltest::temporaryDirectory core-$name]"
1528                 catch {file rename -force \
1529                         [file join $::tcltest::workingDirectory core] \
1530                         [file join $::tcltest::temporaryDirectory \
1531                         core-$name]} msg
1532                 if {[string length $msg] > 0} {
1533                     ::tcltest::PrintError "Problem renaming file: $msg"
1534                 }
1535             } else {
1536                 # Print a message if there is a core file and (1) there
1537                 # previously wasn't one or (2) the new one is different from
1538                 # the old one.
1539
1540                 if {[info exists coreModTime]} {
1541                     if {$coreModTime != [file mtime \
1542                             [file join $::tcltest::workingDirectory core]]} {
1543                         puts $::tcltest::outputChannel "==== $name produced core file!"
1544                     }
1545                 } else {
1546                     puts $::tcltest::outputChannel "==== $name produced core file!"
1547                 }
1548             }
1549         }
1550         array set tcl_platform $currentTclPlatform
1551     }
1552 }
1553
1554 # ::tcltest::getMatchingFiles
1555 #
1556 #       Looks at the patterns given to match and skip files
1557 #       and uses them to put together a list of the tests that will be run.
1558 #
1559 # Arguments:
1560 #       none
1561 #
1562 # Results:
1563 #       The constructed list is returned to the user.  This will primarily
1564 #       be used in 'all.tcl' files.
1565
1566 proc ::tcltest::getMatchingFiles {args} {
1567     set matchingFiles {}
1568     if {[llength $args]} {
1569         set searchDirectory $args
1570     } else {
1571         set searchDirectory [list $::tcltest::testsDirectory]
1572     }
1573     # Find the matching files in the list of directories and then remove the
1574     # ones that match the skip pattern
1575     foreach directory $searchDirectory {
1576         set matchFileList {}
1577         foreach match $::tcltest::matchFiles {
1578             set matchFileList [concat $matchFileList \
1579                     [glob -nocomplain [file join $directory $match]]]
1580         }
1581         if {[string compare {} $::tcltest::skipFiles]} {
1582             set skipFileList {}
1583             foreach skip $::tcltest::skipFiles {
1584                 set skipFileList [concat $skipFileList \
1585                         [glob -nocomplain [file join $directory $skip]]]
1586             }
1587             foreach file $matchFileList {
1588                 # Only include files that don't match the skip pattern and
1589                 # aren't SCCS lock files.
1590                 if {([lsearch -exact $skipFileList $file] == -1) && \
1591                         (![string match l.*.test [file tail $file]])} {
1592                     lappend matchingFiles $file
1593                 }
1594             }
1595         } else {
1596             set matchingFiles [concat $matchingFiles $matchFileList]
1597         }
1598     }
1599     if {[string equal $matchingFiles {}]} {
1600         ::tcltest::PrintError "No test files remain after applying \
1601                 your match and skip patterns!"
1602     }
1603     return $matchingFiles
1604 }
1605
1606 # The following two procs are used in the io tests.
1607
1608 proc ::tcltest::openfiles {} {
1609     if {[catch {testchannel open} result]} {
1610         return {}
1611     }
1612     return $result
1613 }
1614
1615 proc ::tcltest::leakfiles {old} {
1616     if {[catch {testchannel open} new]} {
1617         return {}
1618     }
1619     set leak {}
1620     foreach p $new {
1621         if {[lsearch $old $p] < 0} {
1622             lappend leak $p
1623         }
1624     }
1625     return $leak
1626 }
1627
1628 # ::tcltest::saveState --
1629 #
1630 #       Save information regarding what procs and variables exist.
1631 #
1632 # Arguments:
1633 #       none
1634 #
1635 # Results:
1636 #       Modifies the variable ::tcltest::saveState
1637
1638 proc ::tcltest::saveState {} {
1639     uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
1640     DebugPuts  2 "::tcltest::saveState: $::tcltest::saveState"
1641 }
1642
1643 # ::tcltest::restoreState --
1644 #
1645 #       Remove procs and variables that didn't exist before the call to
1646 #       ::tcltest::saveState.
1647 #
1648 # Arguments:
1649 #       none
1650 #
1651 # Results:
1652 #       Removes procs and variables from your environment if they don't exist
1653 #       in the ::tcltest::saveState variable.
1654
1655 proc ::tcltest::restoreState {} {
1656     foreach p [info procs] {
1657         if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
1658                 (![string equal ::tcltest::$p [namespace origin $p]])} {
1659
1660             DebugPuts 3 "::tcltest::restoreState: Removing proc $p"
1661             rename $p {}
1662         }
1663     }
1664     foreach p [uplevel #0 {info vars}] {
1665         if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
1666             DebugPuts 3 "::tcltest::restoreState: Removing variable $p"
1667             uplevel #0 "catch {unset $p}"
1668         }
1669     }
1670 }
1671
1672 # ::tcltest::normalizeMsg --
1673 #
1674 #       Removes "extra" newlines from a string.
1675 #
1676 # Arguments:
1677 #       msg        String to be modified
1678 #
1679
1680 proc ::tcltest::normalizeMsg {msg} {
1681     regsub "\n$" [string tolower $msg] "" msg
1682     regsub -all "\n\n" $msg "\n" msg
1683     regsub -all "\n\}" $msg "\}" msg
1684     return $msg
1685 }
1686
1687 # makeFile --
1688 #
1689 # Create a new file with the name <name>, and write <contents> to it.
1690 #
1691 # If this file hasn't been created via makeFile since the last time
1692 # cleanupTests was called, add it to the $filesMade list, so it will
1693 # be removed by the next call to cleanupTests.
1694 #
1695 proc ::tcltest::makeFile {contents name} {
1696     global tcl_platform
1697
1698     DebugPuts 3 "::tcltest::makeFile: putting $contents into $name"
1699
1700     set fullName [file join $::tcltest::temporaryDirectory $name]
1701     set fd [open $fullName w]
1702
1703     fconfigure $fd -translation lf
1704
1705     if {[string equal [string index $contents end] "\n"]} {
1706         puts -nonewline $fd $contents
1707     } else {
1708         puts $fd $contents
1709     }
1710     close $fd
1711
1712     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
1713         lappend ::tcltest::filesMade $fullName
1714     }
1715     return $fullName
1716 }
1717
1718 # ::tcltest::removeFile --
1719 #
1720 #       Removes the named file from the filesystem
1721 #
1722 # Arguments:
1723 #       name     file to be removed
1724 #
1725
1726 proc ::tcltest::removeFile {name} {
1727     DebugPuts 3 "::tcltest::removeFile: removing $name"
1728     file delete [file join $::tcltest::temporaryDirectory $name]
1729 }
1730
1731 # makeDirectory --
1732 #
1733 # Create a new dir with the name <name>.
1734 #
1735 # If this dir hasn't been created via makeDirectory since the last time
1736 # cleanupTests was called, add it to the $directoriesMade list, so it will
1737 # be removed by the next call to cleanupTests.
1738 #
1739 proc ::tcltest::makeDirectory {name} {
1740     file mkdir $name
1741
1742     set fullName [file join [pwd] $name]
1743     if {[lsearch -exact $::tcltest::filesMade $fullName] == -1} {
1744         lappend ::tcltest::filesMade $fullName
1745     }
1746 }
1747
1748 # ::tcltest::removeDirectory --
1749 #
1750 #       Removes a named directory from the file system.
1751 #
1752 # Arguments:
1753 #       name    Name of the directory to remove
1754 #
1755
1756 proc ::tcltest::removeDirectory {name} {
1757     file delete -force $name
1758 }
1759
1760 proc ::tcltest::viewFile {name} {
1761     global tcl_platform
1762     if {([string equal $tcl_platform(platform) "macintosh"]) || \
1763             ($::tcltest::testConstraints(unixExecs) == 0)} {
1764         set f [open [file join $::tcltest::temporaryDirectory $name]]
1765         set data [read -nonewline $f]
1766         close $f
1767         return $data
1768     } else {
1769         exec cat [file join $::tcltest::temporaryDirectory $name]
1770     }
1771 }
1772
1773 # grep --
1774 #
1775 # Evaluate a given expression against each element of a list and return all
1776 # elements for which the expression evaluates to true.  For the purposes of
1777 # this proc, use of the keyword "CURRENT_ELEMENT" will flag the proc to use the
1778 # value of the current element within the expression.  This is equivalent to
1779 # the perl grep command where CURRENT_ELEMENT would be the name for the special
1780 # variable $_.
1781 #
1782 # Examples of usage would be:
1783 #   set subList [grep {CURRENT_ELEMENT == 1} $listOfNumbers]
1784 #   set subList [grep {regexp {abc} CURRENT_ELEMENT} $listOfStrings]
1785 #
1786 # Use of the CURRENT_ELEMENT keyword is optional.  If it is left out, it is
1787 # assumed to be the final argument to the expression provided.
1788 #
1789 # Example:
1790 #   grep {regexp a} $someList
1791 #
1792 proc ::tcltest::grep { expression searchList } {
1793     foreach element $searchList {
1794         if {[regsub -all CURRENT_ELEMENT $expression $element \
1795                 newExpression] == 0} {
1796             set newExpression "$expression {$element}"
1797         }
1798         if {[eval $newExpression] == 1} {
1799             lappend returnList $element
1800         }
1801     }
1802     if {[info exists returnList]} {
1803         return $returnList
1804     }
1805     return
1806 }
1807
1808 #
1809 # Construct a string that consists of the requested sequence of bytes,
1810 # as opposed to a string of properly formed UTF-8 characters.
1811 # This allows the tester to
1812 # 1. Create denormalized or improperly formed strings to pass to C procedures
1813 #    that are supposed to accept strings with embedded NULL bytes.
1814 # 2. Confirm that a string result has a certain pattern of bytes, for instance
1815 #    to confirm that "\xe0\0" in a Tcl script is stored internally in
1816 #    UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
1817 #
1818 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
1819 # construct improperly formed strings in this manner, because it involves
1820 # exposing that Tcl uses UTF-8 internally.
1821
1822 proc ::tcltest::bytestring {string} {
1823     encoding convertfrom identity $string
1824 }
1825
1826 #
1827 # Internationalization / ISO support procs     -- dl
1828 #
1829 proc ::tcltest::set_iso8859_1_locale {} {
1830     if {[info commands testlocale] != ""} {
1831         set ::tcltest::previousLocale [testlocale ctype]
1832         testlocale ctype $::tcltest::isoLocale
1833     }
1834     return
1835 }
1836
1837 proc ::tcltest::restore_locale {} {
1838     if {[info commands testlocale] != ""} {
1839         testlocale ctype $::tcltest::previousLocale
1840     }
1841     return
1842 }
1843
1844 # threadReap --
1845 #
1846 #       Kill all threads except for the main thread.
1847 #       Do nothing if testthread is not defined.
1848 #
1849 # Arguments:
1850 #       none.
1851 #
1852 # Results:
1853 #       Returns the number of existing threads.
1854 proc ::tcltest::threadReap {} {
1855     if {[info commands testthread] != {}} {
1856
1857         # testthread built into tcltest
1858
1859         testthread errorproc ThreadNullError
1860         while {[llength [testthread names]] > 1} {
1861             foreach tid [testthread names] {
1862                 if {$tid != $::tcltest::mainThread} {
1863                     catch {testthread send -async $tid {testthread exit}}
1864                 }
1865             }
1866             ## Enter a bit a sleep to give the threads enough breathing
1867             ## room to kill themselves off, otherwise the end up with a
1868             ## massive queue of repeated events
1869             after 1
1870         }
1871         testthread errorproc ThreadError
1872         return [llength [testthread names]]
1873     } elseif {[info commands thread::id] != {}} {
1874
1875         # Thread extension
1876
1877         thread::errorproc ThreadNullError
1878         while {[llength [thread::names]] > 1} {
1879             foreach tid [thread::names] {
1880                 if {$tid != $::tcltest::mainThread} {
1881                     catch {thread::send -async $tid {thread::exit}}
1882                 }
1883             }
1884             ## Enter a bit a sleep to give the threads enough breathing
1885             ## room to kill themselves off, otherwise the end up with a
1886             ## massive queue of repeated events
1887             after 1
1888         }
1889         thread::errorproc ThreadError
1890         return [llength [thread::names]]
1891     } else {
1892         return 1
1893     }
1894 }
1895
1896 # Initialize the constraints and set up command line arguments
1897 namespace eval tcltest {
1898     # Ensure that we have a minimal auto_path so we don't pick up extra junk.
1899     set ::auto_path [list [info library]]
1900
1901     ::tcltest::initConstraints
1902     if {[namespace children ::tcltest] == {}} {
1903         ::tcltest::processCmdLineArgs
1904     }
1905 }
1906