mingw/lib/tcl8/8.5/tcltest-2.3.2.tm

   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,
   6 #       etc. used by Tcl tests.  See the tcltest man page for more
   7 #       details.
   8 #
   9 #       This design was based on the Tcl testing approach designed and
  10 #       initially implemented by Mary Ann May-Pumphrey of Sun
  11 #       Microsystems.
  12 #
  13 # Copyright (c) 1994-1997 Sun Microsystems, Inc.
  14 # Copyright (c) 1998-1999 by Scriptics Corporation.
  15 # Copyright (c) 2000 by Ajuba Solutions
  16 # Contributions from Don Porter, NIST, 2002.  (not subject to US copyright)
  17 # All rights reserved.
  18 #
  19 # RCS: @(#) $Id: tcltest.tcl,v 1.103.2.3 2009/09/01 14:13:02 dgp Exp $
  20
  21 package require Tcl 8.5         ;# -verbose line uses [info frame]
  22 namespace eval tcltest {
  23
  24     # When the version number changes, be sure to update the pkgIndex.tcl file,
  25     # and the install directory in the Makefiles.  When the minor version
  26     # changes (new feature) be sure to update the man page as well.
  27     variable Version 2.3.2
  28
  29     # Compatibility support for dumb variables defined in tcltest 1
  30     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
  31     # yourself.  You don't need tcltest to wrap it for you.
  32     variable version [package provide Tcl]
  33     variable patchLevel [info patchlevel]
  34
  35 ##### Export the public tcltest procs; several categories
  36     #
  37     # Export the main functional commands that do useful things
  38     namespace export cleanupTests loadTestedCommands makeDirectory \
  39         makeFile removeDirectory removeFile runAllTests test
  40
  41     # Export configuration commands that control the functional commands
  42     namespace export configure customMatch errorChannel interpreter \
  43             outputChannel testConstraint
  44
  45     # Export commands that are duplication (candidates for deprecation)
  46     namespace export bytestring         ;# dups [encoding convertfrom identity]
  47     namespace export debug              ;#      [configure -debug]
  48     namespace export errorFile          ;#      [configure -errfile]
  49     namespace export limitConstraints   ;#      [configure -limitconstraints]
  50     namespace export loadFile           ;#      [configure -loadfile]
  51     namespace export loadScript         ;#      [configure -load]
  52     namespace export match              ;#      [configure -match]
  53     namespace export matchFiles         ;#      [configure -file]
  54     namespace export matchDirectories   ;#      [configure -relateddir]
  55     namespace export normalizeMsg       ;#      application of [customMatch]
  56     namespace export normalizePath      ;#      [file normalize] (8.4)
  57     namespace export outputFile         ;#      [configure -outfile]
  58     namespace export preserveCore       ;#      [configure -preservecore]
  59     namespace export singleProcess      ;#      [configure -singleproc]
  60     namespace export skip               ;#      [configure -skip]
  61     namespace export skipFiles          ;#      [configure -notfile]
  62     namespace export skipDirectories    ;#      [configure -asidefromdir]
  63     namespace export temporaryDirectory ;#      [configure -tmpdir]
  64     namespace export testsDirectory     ;#      [configure -testdir]
  65     namespace export verbose            ;#      [configure -verbose]
  66     namespace export viewFile           ;#      binary encoding [read]
  67     namespace export workingDirectory   ;#      [cd] [pwd]
  68
  69     # Export deprecated commands for tcltest 1 compatibility
  70     namespace export getMatchingFiles mainThread restoreState saveState \
  71             threadReap
  72
  73     # tcltest::normalizePath --
  74     #
  75     #     This procedure resolves any symlinks in the path thus creating
  76     #     a path without internal redirection. It assumes that the
  77     #     incoming path is absolute.
  78     #
  79     # Arguments
  80     #     pathVar - name of variable containing path to modify.
  81     #
  82     # Results
  83     #     The path is modified in place.
  84     #
  85     # Side Effects:
  86     #     None.
  87     #
  88     proc normalizePath {pathVar} {
  89         upvar $pathVar path
  90         set oldpwd [pwd]
  91         catch {cd $path}
  92         set path [pwd]
  93         cd $oldpwd
  94         return $path
  95     }
  96
  97 ##### Verification commands used to test values of variables and options
  98     #
  99     # Verification command that accepts everything
 100     proc AcceptAll {value} {
 101         return $value
 102     }
 103
 104     # Verification command that accepts valid Tcl lists
 105     proc AcceptList { list } {
 106         return [lrange $list 0 end]
 107     }
 108
 109     # Verification command that accepts a glob pattern
 110     proc AcceptPattern { pattern } {
 111         return [AcceptAll $pattern]
 112     }
 113
 114     # Verification command that accepts integers
 115     proc AcceptInteger { level } {
 116         return [incr level 0]
 117     }
 118
 119     # Verification command that accepts boolean values
 120     proc AcceptBoolean { boolean } {
 121         return [expr {$boolean && $boolean}]
 122     }
 123
 124     # Verification command that accepts (syntactically) valid Tcl scripts
 125     proc AcceptScript { script } {
 126         if {![info complete $script]} {
 127             return -code error "invalid Tcl script: $script"
 128         }
 129         return $script
 130     }
 131
 132     # Verification command that accepts (converts to) absolute pathnames
 133     proc AcceptAbsolutePath { path } {
 134         return [file join [pwd] $path]
 135     }
 136
 137     # Verification command that accepts existing readable directories
 138     proc AcceptReadable { path } {
 139         if {![file readable $path]} {
 140             return -code error "\"$path\" is not readable"
 141         }
 142         return $path
 143     }
 144     proc AcceptDirectory { directory } {
 145         set directory [AcceptAbsolutePath $directory]
 146         if {![file exists $directory]} {
 147             return -code error "\"$directory\" does not exist"
 148         }
 149         if {![file isdir $directory]} {
 150             return -code error "\"$directory\" is not a directory"
 151         }
 152         return [AcceptReadable $directory]
 153     }
 154
 155 ##### Initialize internal arrays of tcltest, but only if the caller
 156     # has not already pre-initialized them.  This is done to support
 157     # compatibility with older tests that directly access internals
 158     # rather than go through command interfaces.
 159     #
 160     proc ArrayDefault {varName value} {
 161         variable $varName
 162         if {[array exists $varName]} {
 163             return
 164         }
 165         if {[info exists $varName]} {
 166             # Pre-initialized value is a scalar: destroy it!
 167             unset $varName
 168         }
 169         array set $varName $value
 170     }
 171
 172     # save the original environment so that it can be restored later
 173     ArrayDefault originalEnv [array get ::env]
 174
 175     # initialize numTests array to keep track of the number of tests
 176     # that pass, fail, and are skipped.
 177     ArrayDefault numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
 178
 179     # createdNewFiles will store test files as indices and the list of
 180     # files (that should not have been) left behind by the test files
 181     # as values.
 182     ArrayDefault createdNewFiles {}
 183
 184     # initialize skippedBecause array to keep track of constraints that
 185     # kept tests from running; a constraint name of "userSpecifiedSkip"
 186     # means that the test appeared on the list of tests that matched the
 187     # -skip value given to the flag; "userSpecifiedNonMatch" means that
 188     # the test didn't match the argument given to the -match flag; both
 189     # of these constraints are counted only if tcltest::debug is set to
 190     # true.
 191     ArrayDefault skippedBecause {}
 192
 193     # initialize the testConstraints array to keep track of valid
 194     # predefined constraints (see the explanation for the
 195     # InitConstraints proc for more details).
 196     ArrayDefault testConstraints {}
 197
 198 ##### Initialize internal variables of tcltest, but only if the caller
 199     # has not already pre-initialized them.  This is done to support
 200     # compatibility with older tests that directly access internals
 201     # rather than go through command interfaces.
 202     #
 203     proc Default {varName value {verify AcceptAll}} {
 204         variable $varName
 205         if {![info exists $varName]} {
 206             variable $varName [$verify $value]
 207         } else {
 208             variable $varName [$verify [set $varName]]
 209         }
 210     }
 211
 212     # Save any arguments that we might want to pass through to other
 213     # programs.  This is used by the -args flag.
 214     # FINDUSER
 215     Default parameters {}
 216
 217     # Count the number of files tested (0 if runAllTests wasn't called).
 218     # runAllTests will set testSingleFile to false, so stats will
 219     # not be printed until runAllTests calls the cleanupTests proc.
 220     # The currentFailure var stores the boolean value of whether the
 221     # current test file has had any failures.  The failFiles list
 222     # stores the names of test files that had failures.
 223     Default numTestFiles 0 AcceptInteger
 224     Default testSingleFile true AcceptBoolean
 225     Default currentFailure false AcceptBoolean
 226     Default failFiles {} AcceptList
 227
 228     # Tests should remove all files they create.  The test suite will
 229     # check the current working dir for files created by the tests.
 230     # filesMade keeps track of such files created using the makeFile and
 231     # makeDirectory procedures.  filesExisted stores the names of
 232     # pre-existing files.
 233     #
 234     # Note that $filesExisted lists only those files that exist in
 235     # the original [temporaryDirectory].
 236     Default filesMade {} AcceptList
 237     Default filesExisted {} AcceptList
 238     proc FillFilesExisted {} {
 239         variable filesExisted
 240
 241         # Save the names of files that already exist in the scratch directory.
 242         foreach file [glob -nocomplain -directory [temporaryDirectory] *] {
 243             lappend filesExisted [file tail $file]
 244         }
 245
 246         # After successful filling, turn this into a no-op.
 247         proc FillFilesExisted args {}
 248     }
 249
 250     # Kept only for compatibility
 251     Default constraintsSpecified {} AcceptList
 252     trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
 253                 [array names ::tcltest::testConstraints] ;# }
 254
 255     # tests that use threads need to know which is the main thread
 256     Default mainThread 1
 257     variable mainThread
 258     if {[info commands thread::id] != {}} {
 259         set mainThread [thread::id]
 260     } elseif {[info commands testthread] != {}} {
 261         set mainThread [testthread id]
 262     }
 263
 264     # Set workingDirectory to [pwd]. The default output directory for
 265     # Tcl tests is the working directory.  Whenever this value changes
 266     # change to that directory.
 267     variable workingDirectory
 268     trace variable workingDirectory w \
 269             [namespace code {cd $workingDirectory ;#}]
 270
 271     Default workingDirectory [pwd] AcceptAbsolutePath
 272     proc workingDirectory { {dir ""} } {
 273         variable workingDirectory
 274         if {[llength [info level 0]] == 1} {
 275             return $workingDirectory
 276         }
 277         set workingDirectory [AcceptAbsolutePath $dir]
 278     }
 279
 280     # Set the location of the execuatble
 281     Default tcltest [info nameofexecutable]
 282     trace variable tcltest w [namespace code {testConstraint stdio \
 283             [eval [ConstraintInitializer stdio]] ;#}]
 284
 285     # save the platform information so it can be restored later
 286     Default originalTclPlatform [array get ::tcl_platform]
 287
 288     # If a core file exists, save its modification time.
 289     if {[file exists [file join [workingDirectory] core]]} {
 290         Default coreModTime \
 291                 [file mtime [file join [workingDirectory] core]]
 292     }
 293
 294     # stdout and stderr buffers for use when we want to store them
 295     Default outData {}
 296     Default errData {}
 297
 298     # keep track of test level for nested test commands
 299     variable testLevel 0
 300
 301     # the variables and procs that existed when saveState was called are
 302     # stored in a variable of the same name
 303     Default saveState {}
 304
 305     # Internationalization support -- used in [SetIso8859_1_Locale] and
 306     # [RestoreLocale]. Those commands are used in cmdIL.test.
 307
 308     if {![info exists [namespace current]::isoLocale]} {
 309         variable isoLocale fr
 310         switch -- $::tcl_platform(platform) {
 311             "unix" {
 312
 313                 # Try some 'known' values for some platforms:
 314
 315                 switch -exact -- $::tcl_platform(os) {
 316                     "FreeBSD" {
 317                         set isoLocale fr_FR.ISO_8859-1
 318                     }
 319                     HP-UX {
 320                         set isoLocale fr_FR.iso88591
 321                     }
 322                     Linux -
 323                     IRIX {
 324                         set isoLocale fr
 325                     }
 326                     default {
 327
 328                         # Works on SunOS 4 and Solaris, and maybe
 329                         # others...  Define it to something else on your
 330                         # system if you want to test those.
 331
 332                         set isoLocale iso_8859_1
 333                     }
 334                 }
 335             }
 336             "windows" {
 337                 set isoLocale French
 338             }
 339         }
 340     }
 341
 342     variable ChannelsWeOpened; array set ChannelsWeOpened {}
 343     # output goes to stdout by default
 344     Default outputChannel stdout
 345     proc outputChannel { {filename ""} } {
 346         variable outputChannel
 347         variable ChannelsWeOpened
 348
 349         # This is very subtle and tricky, so let me try to explain.
 350         # (Hopefully this longer comment will be clear when I come
 351         # back in a few months, unlike its predecessor :) )
 352         #
 353         # The [outputChannel] command (and underlying variable) have to
 354         # be kept in sync with the [configure -outfile] configuration
 355         # option ( and underlying variable Option(-outfile) ).  This is
 356         # accomplished with a write trace on Option(-outfile) that will
 357         # update [outputChannel] whenver a new value is written.  That
 358         # much is easy.
 359         #
 360         # The trick is that in order to maintain compatibility with
 361         # version 1 of tcltest, we must allow every configuration option
 362         # to get its inital value from command line arguments.  This is
 363         # accomplished by setting initial read traces on all the
 364         # configuration options to parse the command line option the first
 365         # time they are read.  These traces are cancelled whenever the
 366         # program itself calls [configure].
 367         #
 368         # OK, then so to support tcltest 1 compatibility, it seems we want
 369         # to get the return from [outputFile] to trigger the read traces,
 370         # just in case.
 371         #
 372         # BUT!  A little known feature of Tcl variable traces is that
 373         # traces are disabled during the handling of other traces.  So,
 374         # if we trigger read traces on Option(-outfile) and that triggers
 375         # command line parsing which turns around and sets an initial
 376         # value for Option(-outfile) -- <whew!> -- the write trace that
 377         # would keep [outputChannel] in sync with that new initial value
 378         # would not fire!
 379         #
 380         # SO, finally, as a workaround, instead of triggering read traces
 381         # by invoking [outputFile], we instead trigger the same set of
 382         # read traces by invoking [debug].  Any command that reads a
 383         # configuration option would do.  [debug] is just a handy one.
 384         # The end result is that we support tcltest 1 compatibility and
 385         # keep outputChannel and -outfile in sync in all cases.
 386         debug
 387
 388         if {[llength [info level 0]] == 1} {
 389             return $outputChannel
 390         }
 391         if {[info exists ChannelsWeOpened($outputChannel)]} {
 392             close $outputChannel
 393             unset ChannelsWeOpened($outputChannel)
 394         }
 395         switch -exact -- $filename {
 396             stderr -
 397             stdout {
 398                 set outputChannel $filename
 399             }
 400             default {
 401                 set outputChannel [open $filename a]
 402                 set ChannelsWeOpened($outputChannel) 1
 403
 404                 # If we created the file in [temporaryDirectory], then
 405                 # [cleanupTests] will delete it, unless we claim it was
 406                 # already there.
 407                 set outdir [normalizePath [file dirname \
 408                         [file join [pwd] $filename]]]
 409                 if {[string equal $outdir [temporaryDirectory]]} {
 410                     variable filesExisted
 411                     FillFilesExisted
 412                     set filename [file tail $filename]
 413                     if {[lsearch -exact $filesExisted $filename] == -1} {
 414                         lappend filesExisted $filename
 415                     }
 416                 }
 417             }
 418         }
 419         return $outputChannel
 420     }
 421
 422     # errors go to stderr by default
 423     Default errorChannel stderr
 424     proc errorChannel { {filename ""} } {
 425         variable errorChannel
 426         variable ChannelsWeOpened
 427
 428         # This is subtle and tricky.  See the comment above in
 429         # [outputChannel] for a detailed explanation.
 430         debug
 431
 432         if {[llength [info level 0]] == 1} {
 433             return $errorChannel
 434         }
 435         if {[info exists ChannelsWeOpened($errorChannel)]} {
 436             close $errorChannel
 437             unset ChannelsWeOpened($errorChannel)
 438         }
 439         switch -exact -- $filename {
 440             stderr -
 441             stdout {
 442                 set errorChannel $filename
 443             }
 444             default {
 445                 set errorChannel [open $filename a]
 446                 set ChannelsWeOpened($errorChannel) 1
 447
 448                 # If we created the file in [temporaryDirectory], then
 449                 # [cleanupTests] will delete it, unless we claim it was
 450                 # already there.
 451                 set outdir [normalizePath [file dirname \
 452                         [file join [pwd] $filename]]]
 453                 if {[string equal $outdir [temporaryDirectory]]} {
 454                     variable filesExisted
 455                     FillFilesExisted
 456                     set filename [file tail $filename]
 457                     if {[lsearch -exact $filesExisted $filename] == -1} {
 458                         lappend filesExisted $filename
 459                     }
 460                 }
 461             }
 462         }
 463         return $errorChannel
 464     }
 465
 466 ##### Set up the configurable options
 467     #
 468     # The configurable options of the package
 469     variable Option; array set Option {}
 470
 471     # Usage strings for those options
 472     variable Usage; array set Usage {}
 473
 474     # Verification commands for those options
 475     variable Verify; array set Verify {}
 476
 477     # Initialize the default values of the configurable options that are
 478     # historically associated with an exported variable.  If that variable
 479     # is already set, support compatibility by accepting its pre-set value.
 480     # Use [trace] to establish ongoing connection between the deprecated
 481     # exported variable and the modern option kept as a true internal var.
 482     # Also set up usage string and value testing for the option.
 483     proc Option {option value usage {verify AcceptAll} {varName {}}} {
 484         variable Option
 485         variable Verify
 486         variable Usage
 487         variable OptionControlledVariables
 488         set Usage($option) $usage
 489         set Verify($option) $verify
 490         if {[catch {$verify $value} msg]} {
 491             return -code error $msg
 492         } else {
 493             set Option($option) $msg
 494         }
 495         if {[string length $varName]} {
 496             variable $varName
 497             if {[info exists $varName]} {
 498                 if {[catch {$verify [set $varName]} msg]} {
 499                     return -code error $msg
 500                 } else {
 501                     set Option($option) $msg
 502                 }
 503                 unset $varName
 504             }
 505             namespace eval [namespace current] \
 506                     [list upvar 0 Option($option) $varName]
 507             # Workaround for Bug (now Feature Request) 572889.  Grrrr....
 508             # Track all the variables tied to options
 509             lappend OptionControlledVariables $varName
 510             # Later, set auto-configure read traces on all
 511             # of them, since a single trace on Option does not work.
 512             proc $varName {{value {}}} [subst -nocommands {
 513                 if {[llength [info level 0]] == 2} {
 514                     Configure $option [set value]
 515                 }
 516                 return [Configure $option]
 517             }]
 518         }
 519     }
 520
 521     proc MatchingOption {option} {
 522         variable Option
 523         set match [array names Option $option*]
 524         switch -- [llength $match] {
 525             0 {
 526                 set sorted [lsort [array names Option]]
 527                 set values [join [lrange $sorted 0 end-1] ", "]
 528                 append values ", or [lindex $sorted end]"
 529                 return -code error "unknown option $option: should be\
 530                         one of $values"
 531             }
 532             1 {
 533                 return [lindex $match 0]
 534             }
 535             default {
 536                 # Exact match trumps ambiguity
 537                 if {[lsearch -exact $match $option] >= 0} {
 538                     return $option
 539                 }
 540                 set values [join [lrange $match 0 end-1] ", "]
 541                 append values ", or [lindex $match end]"
 542                 return -code error "ambiguous option $option:\
 543                         could match $values"
 544             }
 545         }
 546     }
 547
 548     proc EstablishAutoConfigureTraces {} {
 549         variable OptionControlledVariables
 550         foreach varName [concat $OptionControlledVariables Option] {
 551             variable $varName
 552             trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
 553         }
 554     }
 555
 556     proc RemoveAutoConfigureTraces {} {
 557         variable OptionControlledVariables
 558         foreach varName [concat $OptionControlledVariables Option] {
 559             variable $varName
 560             foreach pair [trace vinfo $varName] {
 561                 foreach {op cmd} $pair break
 562                 if {[string equal r $op]
 563                         && [string match *ProcessCmdLineArgs* $cmd]} {
 564                     trace vdelete $varName $op $cmd
 565                 }
 566             }
 567         }
 568         # Once the traces are removed, this can become a no-op
 569         proc RemoveAutoConfigureTraces {} {}
 570     }
 571
 572     proc Configure args {
 573         variable Option
 574         variable Verify
 575         set n [llength $args]
 576         if {$n == 0} {
 577             return [lsort [array names Option]]
 578         }
 579         if {$n == 1} {
 580             if {[catch {MatchingOption [lindex $args 0]} option]} {
 581                 return -code error $option
 582             }
 583             return $Option($option)
 584         }
 585         while {[llength $args] > 1} {
 586             if {[catch {MatchingOption [lindex $args 0]} option]} {
 587                 return -code error $option
 588             }
 589             if {[catch {$Verify($option) [lindex $args 1]} value]} {
 590                 return -code error "invalid $option\
 591                         value \"[lindex $args 1]\": $value"
 592             }
 593             set Option($option) $value
 594             set args [lrange $args 2 end]
 595         }
 596         if {[llength $args]} {
 597             if {[catch {MatchingOption [lindex $args 0]} option]} {
 598                 return -code error $option
 599             }
 600             return -code error "missing value for option $option"
 601         }
 602     }
 603     proc configure args {
 604         RemoveAutoConfigureTraces
 605         set code [catch {Configure {*}$args} msg]
 606         return -code $code $msg
 607     }
 608
 609     proc AcceptVerbose { level } {
 610         set level [AcceptList $level]
 611         if {[llength $level] == 1} {
 612             if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
 613                 # translate single characters abbreviations to expanded list
 614                 set level [string map {p pass b body s skip t start e error l line} \
 615                         [split $level {}]]
 616             }
 617         }
 618         set valid [list]
 619         foreach v $level {
 620             if {[regexp {^(pass|body|skip|start|error|line)$} $v]} {
 621                 lappend valid $v
 622             }
 623         }
 624         return $valid
 625     }
 626
 627     proc IsVerbose {level} {
 628         variable Option
 629         return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
 630     }
 631
 632     # Default verbosity is to show bodies of failed tests
 633     Option -verbose {body error} {
 634         Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
 635         Test suite will display all passed tests if 'p' is specified, all
 636         skipped tests if 's' is specified, the bodies of failed tests if
 637         'b' is specified, and when tests start if 't' is specified.
 638         ErrorInfo is displayed if 'e' is specified. Source file line
 639         information of failed tests is displayed if 'l' is specified.
 640     } AcceptVerbose verbose
 641
 642     # Match and skip patterns default to the empty list, except for
 643     # matchFiles, which defaults to all .test files in the
 644     # testsDirectory and matchDirectories, which defaults to all
 645     # directories.
 646     Option -match * {
 647         Run all tests within the specified files that match one of the
 648         list of glob patterns given.
 649     } AcceptList match
 650
 651     Option -skip {} {
 652         Skip all tests within the specified tests (via -match) and files
 653         that match one of the list of glob patterns given.
 654     } AcceptList skip
 655
 656     Option -file *.test {
 657         Run tests in all test files that match the glob pattern given.
 658     } AcceptPattern matchFiles
 659
 660     # By default, skip files that appear to be SCCS lock files.
 661     Option -notfile l.*.test {
 662         Skip all test files that match the glob pattern given.
 663     } AcceptPattern skipFiles
 664
 665     Option -relateddir * {
 666         Run tests in directories that match the glob pattern given.
 667     } AcceptPattern matchDirectories
 668
 669     Option -asidefromdir {} {
 670         Skip tests in directories that match the glob pattern given.
 671     } AcceptPattern skipDirectories
 672
 673     # By default, don't save core files
 674     Option -preservecore 0 {
 675         If 2, save any core files produced during testing in the directory
 676         specified by -tmpdir. If 1, notify the user if core files are
 677         created.
 678     } AcceptInteger preserveCore
 679
 680     # debug output doesn't get printed by default; debug level 1 spits
 681     # up only the tests that were skipped because they didn't match or
 682     # were specifically skipped.  A debug level of 2 would spit up the
 683     # tcltest variables and flags provided; a debug level of 3 causes
 684     # some additional output regarding operations of the test harness.
 685     # The tcltest package currently implements only up to debug level 3.
 686     Option -debug 0 {
 687         Internal debug level
 688     } AcceptInteger debug
 689
 690     proc SetSelectedConstraints args {
 691         variable Option
 692         foreach c $Option(-constraints) {
 693             testConstraint $c 1
 694         }
 695     }
 696     Option -constraints {} {
 697         Do not skip the listed constraints listed in -constraints.
 698     } AcceptList
 699     trace variable Option(-constraints) w \
 700             [namespace code {SetSelectedConstraints ;#}]
 701
 702     # Don't run only the "-constraint" specified tests by default
 703     proc ClearUnselectedConstraints args {
 704         variable Option
 705         variable testConstraints
 706         if {!$Option(-limitconstraints)} {return}
 707         foreach c [array names testConstraints] {
 708             if {[lsearch -exact $Option(-constraints) $c] == -1} {
 709                 testConstraint $c 0
 710             }
 711         }
 712     }
 713     Option -limitconstraints false {
 714         whether to run only tests with the constraints
 715     } AcceptBoolean limitConstraints
 716     trace variable Option(-limitconstraints) w \
 717             [namespace code {ClearUnselectedConstraints ;#}]
 718
 719     # A test application has to know how to load the tested commands
 720     # into the interpreter.
 721     Option -load {} {
 722         Specifies the script to load the tested commands.
 723     } AcceptScript loadScript
 724
 725     # Default is to run each test file in a separate process
 726     Option -singleproc 0 {
 727         whether to run all tests in one process
 728     } AcceptBoolean singleProcess
 729
 730     proc AcceptTemporaryDirectory { directory } {
 731         set directory [AcceptAbsolutePath $directory]
 732         if {![file exists $directory]} {
 733             file mkdir $directory
 734         }
 735         set directory [AcceptDirectory $directory]
 736         if {![file writable $directory]} {
 737             if {[string equal [workingDirectory] $directory]} {
 738                 # Special exception: accept the default value
 739                 # even if the directory is not writable
 740                 return $directory
 741             }
 742             return -code error "\"$directory\" is not writeable"
 743         }
 744         return $directory
 745     }
 746
 747     # Directory where files should be created
 748     Option -tmpdir [workingDirectory] {
 749         Save temporary files in the specified directory.
 750     } AcceptTemporaryDirectory temporaryDirectory
 751     trace variable Option(-tmpdir) w \
 752             [namespace code {normalizePath Option(-tmpdir) ;#}]
 753
 754     # Tests should not rely on the current working directory.
 755     # Files that are part of the test suite should be accessed relative
 756     # to [testsDirectory]
 757     Option -testdir [workingDirectory] {
 758         Search tests in the specified directory.
 759     } AcceptDirectory testsDirectory
 760     trace variable Option(-testdir) w \
 761             [namespace code {normalizePath Option(-testdir) ;#}]
 762
 763     proc AcceptLoadFile { file } {
 764         if {[string equal "" $file]} {return $file}
 765         set file [file join [temporaryDirectory] $file]
 766         return [AcceptReadable $file]
 767     }
 768     proc ReadLoadScript {args} {
 769         variable Option
 770         if {[string equal "" $Option(-loadfile)]} {return}
 771         set tmp [open $Option(-loadfile) r]
 772         loadScript [read $tmp]
 773         close $tmp
 774     }
 775     Option -loadfile {} {
 776         Read the script to load the tested commands from the specified file.
 777     } AcceptLoadFile loadFile
 778     trace variable Option(-loadfile) w [namespace code ReadLoadScript]
 779
 780     proc AcceptOutFile { file } {
 781         if {[string equal stderr $file]} {return $file}
 782         if {[string equal stdout $file]} {return $file}
 783         return [file join [temporaryDirectory] $file]
 784     }
 785
 786     # output goes to stdout by default
 787     Option -outfile stdout {
 788         Send output from test runs to the specified file.
 789     } AcceptOutFile outputFile
 790     trace variable Option(-outfile) w \
 791             [namespace code {outputChannel $Option(-outfile) ;#}]
 792
 793     # errors go to stderr by default
 794     Option -errfile stderr {
 795         Send errors from test runs to the specified file.
 796     } AcceptOutFile errorFile
 797     trace variable Option(-errfile) w \
 798             [namespace code {errorChannel $Option(-errfile) ;#}]
 799
 800 }
 801
 802 #####################################################################
 803
 804 # tcltest::Debug* --
 805 #
 806 #     Internal helper procedures to write out debug information
 807 #     dependent on the chosen level. A test shell may overide
 808 #     them, f.e. to redirect the output into a different
 809 #     channel, or even into a GUI.
 810
 811 # tcltest::DebugPuts --
 812 #
 813 #     Prints the specified string if the current debug level is
 814 #     higher than the provided level argument.
 815 #
 816 # Arguments:
 817 #     level   The lowest debug level triggering the output
 818 #     string  The string to print out.
 819 #
 820 # Results:
 821 #     Prints the string. Nothing else is allowed.
 822 #
 823 # Side Effects:
 824 #     None.
 825 #
 826
 827 proc tcltest::DebugPuts {level string} {
 828     variable debug
 829     if {$debug >= $level} {
 830         puts $string
 831     }
 832     return
 833 }
 834
 835 # tcltest::DebugPArray --
 836 #
 837 #     Prints the contents of the specified array if the current
 838 #       debug level is higher than the provided level argument
 839 #
 840 # Arguments:
 841 #     level           The lowest debug level triggering the output
 842 #     arrayvar        The name of the array to print out.
 843 #
 844 # Results:
 845 #     Prints the contents of the array. Nothing else is allowed.
 846 #
 847 # Side Effects:
 848 #     None.
 849 #
 850
 851 proc tcltest::DebugPArray {level arrayvar} {
 852     variable debug
 853
 854     if {$debug >= $level} {
 855         catch {upvar  $arrayvar $arrayvar}
 856         parray $arrayvar
 857     }
 858     return
 859 }
 860
 861 # Define our own [parray] in ::tcltest that will inherit use of the [puts]
 862 # defined in ::tcltest.  NOTE: Ought to construct with [info args] and
 863 # [info default], but can't be bothered now.  If [parray] changes, then
 864 # this will need changing too.
 865 auto_load ::parray
 866 proc tcltest::parray {a {pattern *}} [info body ::parray]
 867
 868 # tcltest::DebugDo --
 869 #
 870 #     Executes the script if the current debug level is greater than
 871 #       the provided level argument
 872 #
 873 # Arguments:
 874 #     level   The lowest debug level triggering the execution.
 875 #     script  The tcl script executed upon a debug level high enough.
 876 #
 877 # Results:
 878 #     Arbitrary side effects, dependent on the executed script.
 879 #
 880 # Side Effects:
 881 #     None.
 882 #
 883
 884 proc tcltest::DebugDo {level script} {
 885     variable debug
 886
 887     if {$debug >= $level} {
 888         uplevel 1 $script
 889     }
 890     return
 891 }
 892
 893 #####################################################################
 894
 895 proc tcltest::Warn {msg} {
 896     puts [outputChannel] "WARNING: $msg"
 897 }
 898
 899 # tcltest::mainThread
 900 #
 901 #     Accessor command for tcltest variable mainThread.
 902 #
 903 proc tcltest::mainThread { {new ""} } {
 904     variable mainThread
 905     if {[llength [info level 0]] == 1} {
 906         return $mainThread
 907     }
 908     set mainThread $new
 909 }
 910
 911 # tcltest::testConstraint --
 912 #
 913 #       sets a test constraint to a value; to do multiple constraints,
 914 #       call this proc multiple times.  also returns the value of the
 915 #       named constraint if no value was supplied.
 916 #
 917 # Arguments:
 918 #       constraint - name of the constraint
 919 #       value - new value for constraint (should be boolean) - if not
 920 #               supplied, this is a query
 921 #
 922 # Results:
 923 #       content of tcltest::testConstraints($constraint)
 924 #
 925 # Side effects:
 926 #       none
 927
 928 proc tcltest::testConstraint {constraint {value ""}} {
 929     variable testConstraints
 930     variable Option
 931     DebugPuts 3 "entering testConstraint $constraint $value"
 932     if {[llength [info level 0]] == 2} {
 933         return $testConstraints($constraint)
 934     }
 935     # Check for boolean values
 936     if {[catch {expr {$value && $value}} msg]} {
 937         return -code error $msg
 938     }
 939     if {[limitConstraints]
 940             && [lsearch -exact $Option(-constraints) $constraint] == -1} {
 941         set value 0
 942     }
 943     set testConstraints($constraint) $value
 944 }
 945
 946 # tcltest::interpreter --
 947 #
 948 #       the interpreter name stored in tcltest::tcltest
 949 #
 950 # Arguments:
 951 #       executable name
 952 #
 953 # Results:
 954 #       content of tcltest::tcltest
 955 #
 956 # Side effects:
 957 #       None.
 958
 959 proc tcltest::interpreter { {interp ""} } {
 960     variable tcltest
 961     if {[llength [info level 0]] == 1} {
 962         return $tcltest
 963     }
 964     if {[string equal {} $interp]} {
 965         set tcltest {}
 966     } else {
 967         set tcltest $interp
 968     }
 969 }
 970
 971 #####################################################################
 972
 973 # tcltest::AddToSkippedBecause --
 974 #
 975 #       Increments the variable used to track how many tests were
 976 #       skipped because of a particular constraint.
 977 #
 978 # Arguments:
 979 #       constraint     The name of the constraint to be modified
 980 #
 981 # Results:
 982 #       Modifies tcltest::skippedBecause; sets the variable to 1 if
 983 #       didn't previously exist - otherwise, it just increments it.
 984 #
 985 # Side effects:
 986 #       None.
 987
 988 proc tcltest::AddToSkippedBecause { constraint {value 1}} {
 989     # add the constraint to the list of constraints that kept tests
 990     # from running
 991     variable skippedBecause
 992
 993     if {[info exists skippedBecause($constraint)]} {
 994         incr skippedBecause($constraint) $value
 995     } else {
 996         set skippedBecause($constraint) $value
 997     }
 998     return
 999 }
1000
1001 # tcltest::PrintError --
1002 #
1003 #       Prints errors to tcltest::errorChannel and then flushes that
1004 #       channel, making sure that all messages are < 80 characters per
1005 #       line.
1006 #
1007 # Arguments:
1008 #       errorMsg     String containing the error to be printed
1009 #
1010 # Results:
1011 #       None.
1012 #
1013 # Side effects:
1014 #       None.
1015
1016 proc tcltest::PrintError {errorMsg} {
1017     set InitialMessage "Error:  "
1018     set InitialMsgLen  [string length $InitialMessage]
1019     puts -nonewline [errorChannel] $InitialMessage
1020
1021     # Keep track of where the end of the string is.
1022     set endingIndex [string length $errorMsg]
1023
1024     if {$endingIndex < (80 - $InitialMsgLen)} {
1025         puts [errorChannel] $errorMsg
1026     } else {
1027         # Print up to 80 characters on the first line, including the
1028         # InitialMessage.
1029         set beginningIndex [string last " " [string range $errorMsg 0 \
1030                 [expr {80 - $InitialMsgLen}]]]
1031         puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
1032
1033         while {![string equal end $beginningIndex]} {
1034             puts -nonewline [errorChannel] \
1035                     [string repeat " " $InitialMsgLen]
1036             if {($endingIndex - $beginningIndex)
1037                     < (80 - $InitialMsgLen)} {
1038                 puts [errorChannel] [string trim \
1039                         [string range $errorMsg $beginningIndex end]]
1040                 break
1041             } else {
1042                 set newEndingIndex [expr {[string last " " \
1043                         [string range $errorMsg $beginningIndex \
1044                                 [expr {$beginningIndex
1045                                         + (80 - $InitialMsgLen)}]
1046                 ]] + $beginningIndex}]
1047                 if {($newEndingIndex <= 0)
1048                         || ($newEndingIndex <= $beginningIndex)} {
1049                     set newEndingIndex end
1050                 }
1051                 puts [errorChannel] [string trim \
1052                         [string range $errorMsg \
1053                             $beginningIndex $newEndingIndex]]
1054                 set beginningIndex $newEndingIndex
1055             }
1056         }
1057     }
1058     flush [errorChannel]
1059     return
1060 }
1061
1062 # tcltest::SafeFetch --
1063 #
1064 #        The following trace procedure makes it so that we can safely
1065 #        refer to non-existent members of the testConstraints array
1066 #        without causing an error.  Instead, reading a non-existent
1067 #        member will return 0. This is necessary because tests are
1068 #        allowed to use constraint "X" without ensuring that
1069 #        testConstraints("X") is defined.
1070 #
1071 # Arguments:
1072 #       n1 - name of the array (testConstraints)
1073 #       n2 - array key value (constraint name)
1074 #       op - operation performed on testConstraints (generally r)
1075 #
1076 # Results:
1077 #       none
1078 #
1079 # Side effects:
1080 #       sets testConstraints($n2) to 0 if it's referenced but never
1081 #       before used
1082
1083 proc tcltest::SafeFetch {n1 n2 op} {
1084     variable testConstraints
1085     DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
1086     if {[string equal {} $n2]} {return}
1087     if {![info exists testConstraints($n2)]} {
1088         if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
1089             testConstraint $n2 0
1090         }
1091     }
1092 }
1093
1094 # tcltest::ConstraintInitializer --
1095 #
1096 #       Get or set a script that when evaluated in the tcltest namespace
1097 #       will return a boolean value with which to initialize the
1098 #       associated constraint.
1099 #
1100 # Arguments:
1101 #       constraint - name of the constraint initialized by the script
1102 #       script - the initializer script
1103 #
1104 # Results
1105 #       boolean value of the constraint - enabled or disabled
1106 #
1107 # Side effects:
1108 #       Constraint is initialized for future reference by [test]
1109 proc tcltest::ConstraintInitializer {constraint {script ""}} {
1110     variable ConstraintInitializer
1111     DebugPuts 3 "entering ConstraintInitializer $constraint $script"
1112     if {[llength [info level 0]] == 2} {
1113         return $ConstraintInitializer($constraint)
1114     }
1115     # Check for boolean values
1116     if {![info complete $script]} {
1117         return -code error "ConstraintInitializer must be complete script"
1118     }
1119     set ConstraintInitializer($constraint) $script
1120 }
1121
1122 # tcltest::InitConstraints --
1123 #
1124 # Call all registered constraint initializers to force initialization
1125 # of all known constraints.
1126 # See the tcltest man page for the list of built-in constraints defined
1127 # in this procedure.
1128 #
1129 # Arguments:
1130 #       none
1131 #
1132 # Results:
1133 #       The testConstraints array is reset to have an index for each
1134 #       built-in test constraint.
1135 #
1136 # Side Effects:
1137 #       None.
1138 #
1139
1140 proc tcltest::InitConstraints {} {
1141     variable ConstraintInitializer
1142     initConstraintsHook
1143     foreach constraint [array names ConstraintInitializer] {
1144         testConstraint $constraint
1145     }
1146 }
1147
1148 proc tcltest::DefineConstraintInitializers {} {
1149     ConstraintInitializer singleTestInterp {singleProcess}
1150
1151     # All the 'pc' constraints are here for backward compatibility and
1152     # are not documented.  They have been replaced with equivalent 'win'
1153     # constraints.
1154
1155     ConstraintInitializer unixOnly \
1156             {string equal $::tcl_platform(platform) unix}
1157     ConstraintInitializer macOnly \
1158             {string equal $::tcl_platform(platform) macintosh}
1159     ConstraintInitializer pcOnly \
1160             {string equal $::tcl_platform(platform) windows}
1161     ConstraintInitializer winOnly \
1162             {string equal $::tcl_platform(platform) windows}
1163
1164     ConstraintInitializer unix {testConstraint unixOnly}
1165     ConstraintInitializer mac {testConstraint macOnly}
1166     ConstraintInitializer pc {testConstraint pcOnly}
1167     ConstraintInitializer win {testConstraint winOnly}
1168
1169     ConstraintInitializer unixOrPc \
1170             {expr {[testConstraint unix] || [testConstraint pc]}}
1171     ConstraintInitializer macOrPc \
1172             {expr {[testConstraint mac] || [testConstraint pc]}}
1173     ConstraintInitializer unixOrWin \
1174             {expr {[testConstraint unix] || [testConstraint win]}}
1175     ConstraintInitializer macOrWin \
1176             {expr {[testConstraint mac] || [testConstraint win]}}
1177     ConstraintInitializer macOrUnix \
1178             {expr {[testConstraint mac] || [testConstraint unix]}}
1179
1180     ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
1181     ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
1182     ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
1183
1184     # The following Constraints switches are used to mark tests that
1185     # should work, but have been temporarily disabled on certain
1186     # platforms because they don't and we haven't gotten around to
1187     # fixing the underlying problem.
1188
1189     ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
1190     ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
1191     ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
1192     ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
1193
1194     # The following Constraints switches are used to mark tests that
1195     # crash on certain platforms, so that they can be reactivated again
1196     # when the underlying problem is fixed.
1197
1198     ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
1199     ConstraintInitializer winCrash {expr {![testConstraint win]}}
1200     ConstraintInitializer macCrash {expr {![testConstraint mac]}}
1201     ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
1202
1203     # Skip empty tests
1204
1205     ConstraintInitializer emptyTest {format 0}
1206
1207     # By default, tests that expose known bugs are skipped.
1208
1209     ConstraintInitializer knownBug {format 0}
1210
1211     # By default, non-portable tests are skipped.
1212
1213     ConstraintInitializer nonPortable {format 0}
1214
1215     # Some tests require user interaction.
1216
1217     ConstraintInitializer userInteraction {format 0}
1218
1219     # Some tests must be skipped if the interpreter is not in
1220     # interactive mode
1221
1222     ConstraintInitializer interactive \
1223             {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
1224
1225     # Some tests can only be run if the installation came from a CD
1226     # image instead of a web image.  Some tests must be skipped if you
1227     # are running as root on Unix.  Other tests can only be run if you
1228     # are running as root on Unix.
1229
1230     ConstraintInitializer root {expr \
1231             {[string equal unix $::tcl_platform(platform)]
1232             && ([string equal root $::tcl_platform(user)]
1233                 || [string equal "" $::tcl_platform(user)])}}
1234     ConstraintInitializer notRoot {expr {![testConstraint root]}}
1235
1236     # Set nonBlockFiles constraint: 1 means this platform supports
1237     # setting files into nonblocking mode.
1238
1239     ConstraintInitializer nonBlockFiles {
1240             set code [expr {[catch {set f [open defs r]}]
1241                     || [catch {fconfigure $f -blocking off}]}]
1242             catch {close $f}
1243             set code
1244     }
1245
1246     # Set asyncPipeClose constraint: 1 means this platform supports
1247     # async flush and async close on a pipe.
1248     #
1249     # Test for SCO Unix - cannot run async flushing tests because a
1250     # potential problem with select is apparently interfering.
1251     # (Mark Diekhans).
1252
1253     ConstraintInitializer asyncPipeClose {expr {
1254             !([string equal unix $::tcl_platform(platform)]
1255             && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
1256
1257     # Test to see if we have a broken version of sprintf with respect
1258     # to the "e" format of floating-point numbers.
1259
1260     ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
1261
1262     # Test to see if execed commands such as cat, echo, rm and so forth
1263     # are present on this machine.
1264
1265     ConstraintInitializer unixExecs {
1266         set code 1
1267         if {[string equal macintosh $::tcl_platform(platform)]} {
1268             set code 0
1269         }
1270         if {[string equal windows $::tcl_platform(platform)]} {
1271             if {[catch {
1272                 set file _tcl_test_remove_me.txt
1273                 makeFile {hello} $file
1274             }]} {
1275                 set code 0
1276             } elseif {
1277                 [catch {exec cat $file}] ||
1278                 [catch {exec echo hello}] ||
1279                 [catch {exec sh -c echo hello}] ||
1280                 [catch {exec wc $file}] ||
1281                 [catch {exec sleep 1}] ||
1282                 [catch {exec echo abc > $file}] ||
1283                 [catch {exec chmod 644 $file}] ||
1284                 [catch {exec rm $file}] ||
1285                 [llength [auto_execok mkdir]] == 0 ||
1286                 [llength [auto_execok fgrep]] == 0 ||
1287                 [llength [auto_execok grep]] == 0 ||
1288                 [llength [auto_execok ps]] == 0
1289             } {
1290                 set code 0
1291             }
1292             removeFile $file
1293         }
1294         set code
1295     }
1296
1297     ConstraintInitializer stdio {
1298         set code 0
1299         if {![catch {set f [open "|[list [interpreter]]" w]}]} {
1300             if {![catch {puts $f exit}]} {
1301                 if {![catch {close $f}]} {
1302                     set code 1
1303                 }
1304             }
1305         }
1306         set code
1307     }
1308
1309     # Deliberately call socket with the wrong number of arguments.  The
1310     # error message you get will indicate whether sockets are available
1311     # on this system.
1312
1313     ConstraintInitializer socket {
1314         catch {socket} msg
1315         string compare $msg "sockets are not available on this system"
1316     }
1317
1318     # Check for internationalization
1319     ConstraintInitializer hasIsoLocale {
1320         if {[llength [info commands testlocale]] == 0} {
1321             set code 0
1322         } else {
1323             set code [string length [SetIso8859_1_Locale]]
1324             RestoreLocale
1325         }
1326         set code
1327     }
1328
1329 }
1330 #####################################################################
1331
1332 # Usage and command line arguments processing.
1333
1334 # tcltest::PrintUsageInfo
1335 #
1336 #       Prints out the usage information for package tcltest.  This can
1337 #       be customized with the redefinition of [PrintUsageInfoHook].
1338 #
1339 # Arguments:
1340 #       none
1341 #
1342 # Results:
1343 #       none
1344 #
1345 # Side Effects:
1346 #       none
1347 proc tcltest::PrintUsageInfo {} {
1348     puts [Usage]
1349     PrintUsageInfoHook
1350 }
1351
1352 proc tcltest::Usage { {option ""} } {
1353     variable Usage
1354     variable Verify
1355     if {[llength [info level 0]] == 1} {
1356         set msg "Usage: [file tail [info nameofexecutable]] script "
1357         append msg "?-help? ?flag value? ... \n"
1358         append msg "Available flags (and valid input values) are:"
1359
1360         set max 0
1361         set allOpts [concat -help [Configure]]
1362         foreach opt $allOpts {
1363             set foo [Usage $opt]
1364             foreach [list x type($opt) usage($opt)] $foo break
1365             set line($opt) "  $opt $type($opt)  "
1366             set length($opt) [string length $line($opt)]
1367             if {$length($opt) > $max} {set max $length($opt)}
1368         }
1369         set rest [expr {72 - $max}]
1370         foreach opt $allOpts {
1371             append msg \n$line($opt)
1372             append msg [string repeat " " [expr {$max - $length($opt)}]]
1373             set u [string trim $usage($opt)]
1374             catch {append u "  (default: \[[Configure $opt]])"}
1375             regsub -all {\s*\n\s*} $u " " u
1376             while {[string length $u] > $rest} {
1377                 set break [string wordstart $u $rest]
1378                 if {$break == 0} {
1379                     set break [string wordend $u 0]
1380                 }
1381                 append msg [string range $u 0 [expr {$break - 1}]]
1382                 set u [string trim [string range $u $break end]]
1383                 append msg \n[string repeat " " $max]
1384             }
1385             append msg $u
1386         }
1387         return $msg\n
1388     } elseif {[string equal -help $option]} {
1389         return [list -help "" "Display this usage information."]
1390     } else {
1391         set type [lindex [info args $Verify($option)] 0]
1392         return [list $option $type $Usage($option)]
1393     }
1394 }
1395
1396 # tcltest::ProcessFlags --
1397 #
1398 #       process command line arguments supplied in the flagArray - this
1399 #       is called by processCmdLineArgs.  Modifies tcltest variables
1400 #       according to the content of the flagArray.
1401 #
1402 # Arguments:
1403 #       flagArray - array containing name/value pairs of flags
1404 #
1405 # Results:
1406 #       sets tcltest variables according to their values as defined by
1407 #       flagArray
1408 #
1409 # Side effects:
1410 #       None.
1411
1412 proc tcltest::ProcessFlags {flagArray} {
1413     # Process -help first
1414     if {[lsearch -exact $flagArray {-help}] != -1} {
1415         PrintUsageInfo
1416         exit 1
1417     }
1418
1419     if {[llength $flagArray] == 0} {
1420         RemoveAutoConfigureTraces
1421     } else {
1422         set args $flagArray
1423         while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
1424
1425             # Something went wrong parsing $args for tcltest options
1426             # Check whether the problem is "unknown option"
1427             if {[regexp {^unknown option (\S+):} $msg -> option]} {
1428                 # Could be this is an option the Hook knows about
1429                 set moreOptions [processCmdLineArgsAddFlagsHook]
1430                 if {[lsearch -exact $moreOptions $option] == -1} {
1431                     # Nope.  Report the error, including additional options,
1432                     # but keep going
1433                     if {[llength $moreOptions]} {
1434                         append msg ", "
1435                         append msg [join [lrange $moreOptions 0 end-1] ", "]
1436                         append msg "or [lindex $moreOptions end]"
1437                     }
1438                     Warn $msg
1439                 }
1440             } else {
1441                 # error is something other than "unknown option"
1442                 # notify user of the error; and exit
1443                 puts [errorChannel] $msg
1444                 exit 1
1445             }
1446
1447             # To recover, find that unknown option and remove up to it.
1448             # then retry
1449             while {![string equal [lindex $args 0] $option]} {
1450                 set args [lrange $args 2 end]
1451             }
1452             set args [lrange $args 2 end]
1453         }
1454         if {[llength $args] == 1} {
1455             puts [errorChannel] \
1456                     "missing value for option [lindex $args 0]"
1457             exit 1
1458         }
1459     }
1460
1461     # Call the hook
1462     catch {
1463         array set flag $flagArray
1464         processCmdLineArgsHook [array get flag]
1465     }
1466     return
1467 }
1468
1469 # tcltest::ProcessCmdLineArgs --
1470 #
1471 #       This procedure must be run after constraint initialization is
1472 #       set up (by [DefineConstraintInitializers]) because some constraints
1473 #       can be overridden.
1474 #
1475 #       Perform configuration according to the command-line options.
1476 #
1477 # Arguments:
1478 #       none
1479 #
1480 # Results:
1481 #       Sets the above-named variables in the tcltest namespace.
1482 #
1483 # Side Effects:
1484 #       None.
1485 #
1486
1487 proc tcltest::ProcessCmdLineArgs {} {
1488     variable originalEnv
1489     variable testConstraints
1490
1491     # The "argv" var doesn't exist in some cases, so use {}.
1492     if {![info exists ::argv]} {
1493         ProcessFlags {}
1494     } else {
1495         ProcessFlags $::argv
1496     }
1497
1498     # Spit out everything you know if we're at a debug level 2 or
1499     # greater
1500     DebugPuts 2 "Flags passed into tcltest:"
1501     if {[info exists ::env(TCLTEST_OPTIONS)]} {
1502         DebugPuts 2 \
1503                 "    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
1504     }
1505     if {[info exists ::argv]} {
1506         DebugPuts 2 "    argv: $::argv"
1507     }
1508     DebugPuts    2 "tcltest::debug              = [debug]"
1509     DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
1510     DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
1511     DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
1512     DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
1513     DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
1514     DebugPuts    2 "Original environment (tcltest::originalEnv):"
1515     DebugPArray  2 originalEnv
1516     DebugPuts    2 "Constraints:"
1517     DebugPArray  2 testConstraints
1518 }
1519
1520 #####################################################################
1521
1522 # Code to run the tests goes here.
1523
1524 # tcltest::TestPuts --
1525 #
1526 #       Used to redefine puts in test environment.  Stores whatever goes
1527 #       out on stdout in tcltest::outData and stderr in errData before
1528 #       sending it on to the regular puts.
1529 #
1530 # Arguments:
1531 #       same as standard puts
1532 #
1533 # Results:
1534 #       none
1535 #
1536 # Side effects:
1537 #       Intercepts puts; data that would otherwise go to stdout, stderr,
1538 #       or file channels specified in outputChannel and errorChannel
1539 #       does not get sent to the normal puts function.
1540 namespace eval tcltest::Replace {
1541     namespace export puts
1542 }
1543 proc tcltest::Replace::puts {args} {
1544     variable [namespace parent]::outData
1545     variable [namespace parent]::errData
1546     switch [llength $args] {
1547         1 {
1548             # Only the string to be printed is specified
1549             append outData [lindex $args 0]\n
1550             return
1551             # return [Puts [lindex $args 0]]
1552         }
1553         2 {
1554             # Either -nonewline or channelId has been specified
1555             if {[string equal -nonewline [lindex $args 0]]} {
1556                 append outData [lindex $args end]
1557                 return
1558                 # return [Puts -nonewline [lindex $args end]]
1559             } else {
1560                 set channel [lindex $args 0]
1561                 set newline \n
1562             }
1563         }
1564         3 {
1565             if {[string equal -nonewline [lindex $args 0]]} {
1566                 # Both -nonewline and channelId are specified, unless
1567                 # it's an error.  -nonewline is supposed to be argv[0].
1568                 set channel [lindex $args 1]
1569                 set newline ""
1570             }
1571         }
1572     }
1573
1574     if {[info exists channel]} {
1575         if {[string equal $channel [[namespace parent]::outputChannel]]
1576                 || [string equal $channel stdout]} {
1577             append outData [lindex $args end]$newline
1578             return
1579         } elseif {[string equal $channel [[namespace parent]::errorChannel]]
1580                 || [string equal $channel stderr]} {
1581             append errData [lindex $args end]$newline
1582             return
1583         }
1584     }
1585
1586     # If we haven't returned by now, we don't know how to handle the
1587     # input.  Let puts handle it.
1588     return [Puts {*}$args]
1589 }
1590
1591 # tcltest::Eval --
1592 #
1593 #       Evaluate the script in the test environment.  If ignoreOutput is
1594 #       false, store data sent to stderr and stdout in outData and
1595 #       errData.  Otherwise, ignore this output altogether.
1596 #
1597 # Arguments:
1598 #       script             Script to evaluate
1599 #       ?ignoreOutput?     Indicates whether or not to ignore output
1600 #                          sent to stdout & stderr
1601 #
1602 # Results:
1603 #       result from running the script
1604 #
1605 # Side effects:
1606 #       Empties the contents of outData and errData before running a
1607 #       test if ignoreOutput is set to 0.
1608
1609 proc tcltest::Eval {script {ignoreOutput 1}} {
1610     variable outData
1611     variable errData
1612     DebugPuts 3 "[lindex [info level 0] 0] called"
1613     if {!$ignoreOutput} {
1614         set outData {}
1615         set errData {}
1616         rename ::puts [namespace current]::Replace::Puts
1617         namespace eval :: [list namespace import [namespace origin Replace::puts]]
1618         namespace import Replace::puts
1619     }
1620     set result [uplevel 1 $script]
1621     if {!$ignoreOutput} {
1622         namespace forget puts
1623         namespace eval :: namespace forget puts
1624         rename [namespace current]::Replace::Puts ::puts
1625     }
1626     return $result
1627 }
1628
1629 # tcltest::CompareStrings --
1630 #
1631 #       compares the expected answer to the actual answer, depending on
1632 #       the mode provided.  Mode determines whether a regexp, exact,
1633 #       glob or custom comparison is done.
1634 #
1635 # Arguments:
1636 #       actual - string containing the actual result
1637 #       expected - pattern to be matched against
1638 #       mode - type of comparison to be done
1639 #
1640 # Results:
1641 #       result of the match
1642 #
1643 # Side effects:
1644 #       None.
1645
1646 proc tcltest::CompareStrings {actual expected mode} {
1647     variable CustomMatch
1648     if {![info exists CustomMatch($mode)]} {
1649         return -code error "No matching command registered for `-match $mode'"
1650     }
1651     set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
1652     if {[catch {expr {$match && $match}} result]} {
1653         return -code error "Invalid result from `-match $mode' command: $result"
1654     }
1655     return $match
1656 }
1657
1658 # tcltest::customMatch --
1659 #
1660 #       registers a command to be called when a particular type of
1661 #       matching is required.
1662 #
1663 # Arguments:
1664 #       nickname - Keyword for the type of matching
1665 #       cmd - Incomplete command that implements that type of matching
1666 #               when completed with expected string and actual string
1667 #               and then evaluated.
1668 #
1669 # Results:
1670 #       None.
1671 #
1672 # Side effects:
1673 #       Sets the variable tcltest::CustomMatch
1674
1675 proc tcltest::customMatch {mode script} {
1676     variable CustomMatch
1677     if {![info complete $script]} {
1678         return -code error \
1679                 "invalid customMatch script; can't evaluate after completion"
1680     }
1681     set CustomMatch($mode) $script
1682 }
1683
1684 # tcltest::SubstArguments list
1685 #
1686 # This helper function takes in a list of words, then perform a
1687 # substitution on the list as though each word in the list is a separate
1688 # argument to the Tcl function.  For example, if this function is
1689 # invoked as:
1690 #
1691 #      SubstArguments {$a {$a}}
1692 #
1693 # Then it is as though the function is invoked as:
1694 #
1695 #      SubstArguments $a {$a}
1696 #
1697 # This code is adapted from Paul Duffin's function "SplitIntoWords".
1698 # The original function can be found  on:
1699 #
1700 #      http://purl.org/thecliff/tcl/wiki/858.html
1701 #
1702 # Results:
1703 #     a list containing the result of the substitution
1704 #
1705 # Exceptions:
1706 #     An error may occur if the list containing unbalanced quote or
1707 #     unknown variable.
1708 #
1709 # Side Effects:
1710 #     None.
1711 #
1712
1713 proc tcltest::SubstArguments {argList} {
1714
1715     # We need to split the argList up into tokens but cannot use list
1716     # operations as they throw away some significant quoting, and
1717     # [split] ignores braces as it should.  Therefore what we do is
1718     # gradually build up a string out of whitespace seperated strings.
1719     # We cannot use [split] to split the argList into whitespace
1720     # separated strings as it throws away the whitespace which maybe
1721     # important so we have to do it all by hand.
1722
1723     set result {}
1724     set token ""
1725
1726     while {[string length $argList]} {
1727         # Look for the next word containing a quote: " { }
1728         if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
1729                 $argList all]} {
1730             # Get the text leading up to this word, but not including
1731             # this word, from the argList.
1732             set text [string range $argList 0 \
1733                     [expr {[lindex $all 0] - 1}]]
1734             # Get the word with the quote
1735             set word [string range $argList \
1736                     [lindex $all 0] [lindex $all 1]]
1737
1738             # Remove all text up to and including the word from the
1739             # argList.
1740             set argList [string range $argList \
1741                     [expr {[lindex $all 1] + 1}] end]
1742         } else {
1743             # Take everything up to the end of the argList.
1744             set text $argList
1745             set word {}
1746             set argList {}
1747         }
1748
1749         if {$token != {}} {
1750             # If we saw a word with quote before, then there is a
1751             # multi-word token starting with that word.  In this case,
1752             # add the text and the current word to this token.
1753             append token $text $word
1754         } else {
1755             # Add the text to the result.  There is no need to parse
1756             # the text because it couldn't be a part of any multi-word
1757             # token.  Then start a new multi-word token with the word
1758             # because we need to pass this token to the Tcl parser to
1759             # check for balancing quotes
1760             append result $text
1761             set token $word
1762         }
1763
1764         if { [catch {llength $token} length] == 0 && $length == 1} {
1765             # The token is a valid list so add it to the result.
1766             # lappend result [string trim $token]
1767             append result \{$token\}
1768             set token {}
1769         }
1770     }
1771
1772     # If the last token has not been added to the list then there
1773     # is a problem.
1774     if { [string length $token] } {
1775         error "incomplete token \"$token\""
1776     }
1777
1778     return $result
1779 }
1780
1781
1782 # tcltest::test --
1783 #
1784 # This procedure runs a test and prints an error message if the test
1785 # fails.  If verbose has been set, it also prints a message even if the
1786 # test succeeds.  The test will be skipped if it doesn't match the
1787 # match variable, if it matches an element in skip, or if one of the
1788 # elements of "constraints" turns out not to be true.
1789 #
1790 # If testLevel is 1, then this is a top level test, and we record
1791 # pass/fail information; otherwise, this information is not logged and
1792 # is not added to running totals.
1793 #
1794 # Attributes:
1795 #   Only description is a required attribute.  All others are optional.
1796 #   Default values are indicated.
1797 #
1798 #   constraints -       A list of one or more keywords, each of which
1799 #                       must be the name of an element in the array
1800 #                       "testConstraints".  If any of these elements is
1801 #                       zero, the test is skipped. This attribute is
1802 #                       optional; default is {}
1803 #   body -              Script to run to carry out the test.  It must
1804 #                       return a result that can be checked for
1805 #                       correctness.  This attribute is optional;
1806 #                       default is {}
1807 #   result -            Expected result from script.  This attribute is
1808 #                       optional; default is {}.
1809 #   output -            Expected output sent to stdout.  This attribute
1810 #                       is optional; default is {}.
1811 #   errorOutput -       Expected output sent to stderr.  This attribute
1812 #                       is optional; default is {}.
1813 #   returnCodes -       Expected return codes.  This attribute is
1814 #                       optional; default is {0 2}.
1815 #   setup -             Code to run before $script (above).  This
1816 #                       attribute is optional; default is {}.
1817 #   cleanup -           Code to run after $script (above).  This
1818 #                       attribute is optional; default is {}.
1819 #   match -             specifies type of matching to do on result,
1820 #                       output, errorOutput; this must be a string
1821 #                       previously registered by a call to [customMatch].
1822 #                       The strings exact, glob, and regexp are pre-registered
1823 #                       by the tcltest package.  Default value is exact.
1824 #
1825 # Arguments:
1826 #   name -              Name of test, in the form foo-1.2.
1827 #   description -       Short textual description of the test, to
1828 #                       help humans understand what it does.
1829 #
1830 # Results:
1831 #       None.
1832 #
1833 # Side effects:
1834 #       Just about anything is possible depending on the test.
1835 #
1836
1837 proc tcltest::test {name description args} {
1838     global tcl_platform
1839     variable testLevel
1840     variable coreModTime
1841     DebugPuts 3 "test $name $args"
1842     DebugDo 1 {
1843         variable TestNames
1844         catch {
1845             puts "test name '$name' re-used; prior use in $TestNames($name)"
1846         }
1847         set TestNames($name) [info script]
1848     }
1849
1850     FillFilesExisted
1851     incr testLevel
1852
1853     # Pre-define everything to null except output and errorOutput.  We
1854     # determine whether or not to trap output based on whether or not
1855     # these variables (output & errorOutput) are defined.
1856     foreach item {constraints setup cleanup body result returnCodes
1857             match} {
1858         set $item {}
1859     }
1860
1861     # Set the default match mode
1862     set match exact
1863
1864     # Set the default match values for return codes (0 is the standard
1865     # expected return value if everything went well; 2 represents
1866     # 'return' being used in the test script).
1867     set returnCodes [list 0 2]
1868
1869     # The old test format can't have a 3rd argument (constraints or
1870     # script) that starts with '-'.
1871     if {[string match -* [lindex $args 0]]
1872             || ([llength $args] <= 1)} {
1873         if {[llength $args] == 1} {
1874             set list [SubstArguments [lindex $args 0]]
1875             foreach {element value} $list {
1876                 set testAttributes($element) $value
1877             }
1878             foreach item {constraints match setup body cleanup \
1879                     result returnCodes output errorOutput} {
1880                 if {[info exists testAttributes(-$item)]} {
1881                     set testAttributes(-$item) [uplevel 1 \
1882                             ::concat $testAttributes(-$item)]
1883                 }
1884             }
1885         } else {
1886             array set testAttributes $args
1887         }
1888
1889         set validFlags {-setup -cleanup -body -result -returnCodes \
1890                 -match -output -errorOutput -constraints}
1891
1892         foreach flag [array names testAttributes] {
1893             if {[lsearch -exact $validFlags $flag] == -1} {
1894                 incr testLevel -1
1895                 set sorted [lsort $validFlags]
1896                 set options [join [lrange $sorted 0 end-1] ", "]
1897                 append options ", or [lindex $sorted end]"
1898                 return -code error "bad option \"$flag\": must be $options"
1899             }
1900         }
1901
1902         # store whatever the user gave us
1903         foreach item [array names testAttributes] {
1904             set [string trimleft $item "-"] $testAttributes($item)
1905         }
1906
1907         # Check the values supplied for -match
1908         variable CustomMatch
1909         if {[lsearch [array names CustomMatch] $match] == -1} {
1910             incr testLevel -1
1911             set sorted [lsort [array names CustomMatch]]
1912             set values [join [lrange $sorted 0 end-1] ", "]
1913             append values ", or [lindex $sorted end]"
1914             return -code error "bad -match value \"$match\":\
1915                     must be $values"
1916         }
1917
1918         # Replace symbolic valies supplied for -returnCodes
1919         foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
1920             set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
1921         }
1922     } else {
1923         # This is parsing for the old test command format; it is here
1924         # for backward compatibility.
1925         set result [lindex $args end]
1926         if {[llength $args] == 2} {
1927             set body [lindex $args 0]
1928         } elseif {[llength $args] == 3} {
1929             set constraints [lindex $args 0]
1930             set body [lindex $args 1]
1931         } else {
1932             incr testLevel -1
1933             return -code error "wrong # args:\
1934                     should be \"test name desc ?options?\""
1935         }
1936     }
1937
1938     if {[Skipped $name $constraints]} {
1939         incr testLevel -1
1940         return
1941     }
1942
1943     # Save information about the core file.
1944     if {[preserveCore]} {
1945         if {[file exists [file join [workingDirectory] core]]} {
1946             set coreModTime [file mtime [file join [workingDirectory] core]]
1947         }
1948     }
1949
1950     # First, run the setup script
1951     set code [catch {uplevel 1 $setup} setupMsg]
1952     if {$code == 1} {
1953         set errorInfo(setup) $::errorInfo
1954         set errorCode(setup) $::errorCode
1955     }
1956     set setupFailure [expr {$code != 0}]
1957
1958     # Only run the test body if the setup was successful
1959     if {!$setupFailure} {
1960
1961         # Verbose notification of $body start
1962         if {[IsVerbose start]} {
1963             puts [outputChannel] "---- $name start"
1964             flush [outputChannel]
1965         }
1966
1967         set command [list [namespace origin RunTest] $name $body]
1968         if {[info exists output] || [info exists errorOutput]} {
1969             set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
1970         } else {
1971             set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
1972         }
1973         foreach {actualAnswer returnCode} $testResult break
1974         if {$returnCode == 1} {
1975             set errorInfo(body) $::errorInfo
1976             set errorCode(body) $::errorCode
1977         }
1978     }
1979
1980     # Always run the cleanup script
1981     set code [catch {uplevel 1 $cleanup} cleanupMsg]
1982     if {$code == 1} {
1983         set errorInfo(cleanup) $::errorInfo
1984         set errorCode(cleanup) $::errorCode
1985     }
1986     set cleanupFailure [expr {$code != 0}]
1987
1988     set coreFailure 0
1989     set coreMsg ""
1990     # check for a core file first - if one was created by the test,
1991     # then the test failed
1992     if {[preserveCore]} {
1993         if {[file exists [file join [workingDirectory] core]]} {
1994             # There's only a test failure if there is a core file
1995             # and (1) there previously wasn't one or (2) the new
1996             # one is different from the old one.
1997             if {[info exists coreModTime]} {
1998                 if {$coreModTime != [file mtime \
1999                         [file join [workingDirectory] core]]} {
2000                     set coreFailure 1
2001                 }
2002             } else {
2003                 set coreFailure 1
2004             }
2005
2006             if {([preserveCore] > 1) && ($coreFailure)} {
2007                 append coreMsg "\nMoving file to:\
2008                     [file join [temporaryDirectory] core-$name]"
2009                 catch {file rename -force \
2010                     [file join [workingDirectory] core] \
2011                     [file join [temporaryDirectory] core-$name]
2012                 } msg
2013                 if {[string length $msg] > 0} {
2014                     append coreMsg "\nError:\
2015                         Problem renaming core file: $msg"
2016                 }
2017             }
2018         }
2019     }
2020
2021     # check if the return code matched the expected return code
2022     set codeFailure 0
2023     if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
2024         set codeFailure 1
2025     }
2026
2027     # If expected output/error strings exist, we have to compare
2028     # them.  If the comparison fails, then so did the test.
2029     set outputFailure 0
2030     variable outData
2031     if {[info exists output] && !$codeFailure} {
2032         if {[set outputCompare [catch {
2033             CompareStrings $outData $output $match
2034         } outputMatch]] == 0} {
2035             set outputFailure [expr {!$outputMatch}]
2036         } else {
2037             set outputFailure 1
2038         }
2039     }
2040
2041     set errorFailure 0
2042     variable errData
2043     if {[info exists errorOutput] && !$codeFailure} {
2044         if {[set errorCompare [catch {
2045             CompareStrings $errData $errorOutput $match
2046         } errorMatch]] == 0} {
2047             set errorFailure [expr {!$errorMatch}]
2048         } else {
2049             set errorFailure 1
2050         }
2051     }
2052
2053     # check if the answer matched the expected answer
2054     # Only check if we ran the body of the test (no setup failure)
2055     if {$setupFailure || $codeFailure} {
2056         set scriptFailure 0
2057     } elseif {[set scriptCompare [catch {
2058         CompareStrings $actualAnswer $result $match
2059     } scriptMatch]] == 0} {
2060         set scriptFailure [expr {!$scriptMatch}]
2061     } else {
2062         set scriptFailure 1
2063     }
2064
2065     # if we didn't experience any failures, then we passed
2066     variable numTests
2067     if {!($setupFailure || $cleanupFailure || $coreFailure
2068             || $outputFailure || $errorFailure || $codeFailure
2069             || $scriptFailure)} {
2070         if {$testLevel == 1} {
2071             incr numTests(Passed)
2072             if {[IsVerbose pass]} {
2073                 puts [outputChannel] "++++ $name PASSED"
2074             }
2075         }
2076         incr testLevel -1
2077         return
2078     }
2079
2080     # We know the test failed, tally it...
2081     if {$testLevel == 1} {
2082         incr numTests(Failed)
2083     }
2084
2085     # ... then report according to the type of failure
2086     variable currentFailure true
2087     if {![IsVerbose body]} {
2088         set body ""
2089     }
2090     puts [outputChannel] "\n"
2091     if {[IsVerbose line]} {
2092         if {![catch {set testFrame [info frame -1]}] &&
2093                 [dict get $testFrame type] eq "source"} {
2094             set testFile [dict get $testFrame file]
2095             set testLine [dict get $testFrame line]
2096         } else {
2097             set testFile [file normalize [uplevel 1 {info script}]]
2098             if {[file readable $testFile]} {
2099                 set testFd [open $testFile r]
2100                 set testLine [expr {[lsearch -regexp \
2101                         [split [read $testFd] "\n"] \
2102                         "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
2103                 close $testFd
2104             }
2105         }
2106         if {[info exists testLine]} {
2107             puts [outputChannel] "$testFile:$testLine: error: test failed:\
2108                     $name [string trim $description]"
2109         }
2110     }
2111     puts [outputChannel] "==== $name\
2112             [string trim $description] FAILED"
2113     if {[string length $body]} {
2114         puts [outputChannel] "==== Contents of test case:"
2115         puts [outputChannel] $body
2116     }
2117     if {$setupFailure} {
2118         puts [outputChannel] "---- Test setup\
2119                 failed:\n$setupMsg"
2120         if {[info exists errorInfo(setup)]} {
2121             puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
2122             puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
2123         }
2124     }
2125     if {$scriptFailure} {
2126         if {$scriptCompare} {
2127             puts [outputChannel] "---- Error testing result: $scriptMatch"
2128         } else {
2129             puts [outputChannel] "---- Result was:\n$actualAnswer"
2130             puts [outputChannel] "---- Result should have been\
2131                     ($match matching):\n$result"
2132         }
2133     }
2134     if {$codeFailure} {
2135         switch -- $returnCode {
2136             0 { set msg "Test completed normally" }
2137             1 { set msg "Test generated error" }
2138             2 { set msg "Test generated return exception" }
2139             3 { set msg "Test generated break exception" }
2140             4 { set msg "Test generated continue exception" }
2141             default { set msg "Test generated exception" }
2142         }
2143         puts [outputChannel] "---- $msg; Return code was: $returnCode"
2144         puts [outputChannel] "---- Return code should have been\
2145                 one of: $returnCodes"
2146         if {[IsVerbose error]} {
2147             if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
2148                 puts [outputChannel] "---- errorInfo: $errorInfo(body)"
2149                 puts [outputChannel] "---- errorCode: $errorCode(body)"
2150             }
2151         }
2152     }
2153     if {$outputFailure} {
2154         if {$outputCompare} {
2155             puts [outputChannel] "---- Error testing output: $outputMatch"
2156         } else {
2157             puts [outputChannel] "---- Output was:\n$outData"
2158             puts [outputChannel] "---- Output should have been\
2159                     ($match matching):\n$output"
2160         }
2161     }
2162     if {$errorFailure} {
2163         if {$errorCompare} {
2164             puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
2165         } else {
2166             puts [outputChannel] "---- Error output was:\n$errData"
2167             puts [outputChannel] "---- Error output should have\
2168                     been ($match matching):\n$errorOutput"
2169         }
2170     }
2171     if {$cleanupFailure} {
2172         puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
2173         if {[info exists errorInfo(cleanup)]} {
2174             puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
2175             puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
2176         }
2177     }
2178     if {$coreFailure} {
2179         puts [outputChannel] "---- Core file produced while running\
2180                 test!  $coreMsg"
2181     }
2182     puts [outputChannel] "==== $name FAILED\n"
2183
2184     incr testLevel -1
2185     return
2186 }
2187
2188 # Skipped --
2189 #
2190 # Given a test name and it constraints, returns a boolean indicating
2191 # whether the current configuration says the test should be skipped.
2192 #
2193 # Side Effects:  Maintains tally of total tests seen and tests skipped.
2194 #
2195 proc tcltest::Skipped {name constraints} {
2196     variable testLevel
2197     variable numTests
2198     variable testConstraints
2199
2200     if {$testLevel == 1} {
2201         incr numTests(Total)
2202     }
2203     # skip the test if it's name matches an element of skip
2204     foreach pattern [skip] {
2205         if {[string match $pattern $name]} {
2206             if {$testLevel == 1} {
2207                 incr numTests(Skipped)
2208                 DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
2209             }
2210             return 1
2211         }
2212     }
2213     # skip the test if it's name doesn't match any element of match
2214     set ok 0
2215     foreach pattern [match] {
2216         if {[string match $pattern $name]} {
2217             set ok 1
2218             break
2219         }
2220     }
2221     if {!$ok} {
2222         if {$testLevel == 1} {
2223             incr numTests(Skipped)
2224             DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
2225         }
2226         return 1
2227     }
2228     if {[string equal {} $constraints]} {
2229         # If we're limited to the listed constraints and there aren't
2230         # any listed, then we shouldn't run the test.
2231         if {[limitConstraints]} {
2232             AddToSkippedBecause userSpecifiedLimitConstraint
2233             if {$testLevel == 1} {
2234                 incr numTests(Skipped)
2235             }
2236             return 1
2237         }
2238     } else {
2239         # "constraints" argument exists;
2240         # make sure that the constraints are satisfied.
2241
2242         set doTest 0
2243         if {[string match {*[$\[]*} $constraints] != 0} {
2244             # full expression, e.g. {$foo > [info tclversion]}
2245             catch {set doTest [uplevel #0 [list expr $constraints]]}
2246         } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
2247             # something like {a || b} should be turned into
2248             # $testConstraints(a) || $testConstraints(b).
2249             regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
2250             catch {set doTest [eval [list expr $c]]}
2251         } elseif {![catch {llength $constraints}]} {
2252             # just simple constraints such as {unixOnly fonts}.
2253             set doTest 1
2254             foreach constraint $constraints {
2255                 if {(![info exists testConstraints($constraint)]) \
2256                         || (!$testConstraints($constraint))} {
2257                     set doTest 0
2258
2259                     # store the constraint that kept the test from
2260                     # running
2261                     set constraints $constraint
2262                     break
2263                 }
2264             }
2265         }
2266
2267         if {!$doTest} {
2268             if {[IsVerbose skip]} {
2269                 puts [outputChannel] "++++ $name SKIPPED: $constraints"
2270             }
2271
2272             if {$testLevel == 1} {
2273                 incr numTests(Skipped)
2274                 AddToSkippedBecause $constraints
2275             }
2276             return 1
2277         }
2278     }
2279     return 0
2280 }
2281
2282 # RunTest --
2283 #
2284 # This is where the body of a test is evaluated.  The combination of
2285 # [RunTest] and [Eval] allows the output and error output of the test
2286 # body to be captured for comparison against the expected values.
2287
2288 proc tcltest::RunTest {name script} {
2289     DebugPuts 3 "Running $name {$script}"
2290
2291     # If there is no "memory" command (because memory debugging isn't
2292     # enabled), then don't attempt to use the command.
2293
2294     if {[llength [info commands memory]] == 1} {
2295         memory tag $name
2296     }
2297
2298     set code [catch {uplevel 1 $script} actualAnswer]
2299
2300     return [list $actualAnswer $code]
2301 }
2302
2303 #####################################################################
2304
2305 # tcltest::cleanupTestsHook --
2306 #
2307 #       This hook allows a harness that builds upon tcltest to specify
2308 #       additional things that should be done at cleanup.
2309 #
2310
2311 if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
2312     proc tcltest::cleanupTestsHook {} {}
2313 }
2314
2315 # tcltest::cleanupTests --
2316 #
2317 # Remove files and dirs created using the makeFile and makeDirectory
2318 # commands since the last time this proc was invoked.
2319 #
2320 # Print the names of the files created without the makeFile command
2321 # since the tests were invoked.
2322 #
2323 # Print the number tests (total, passed, failed, and skipped) since the
2324 # tests were invoked.
2325 #
2326 # Restore original environment (as reported by special variable env).
2327 #
2328 # Arguments:
2329 #      calledFromAllFile - if 0, behave as if we are running a single
2330 #      test file within an entire suite of tests.  if we aren't running
2331 #      a single test file, then don't report status.  check for new
2332 #      files created during the test run and report on them.  if 1,
2333 #      report collated status from all the test file runs.
2334 #
2335 # Results:
2336 #      None.
2337 #
2338 # Side Effects:
2339 #      None
2340 #
2341
2342 proc tcltest::cleanupTests {{calledFromAllFile 0}} {
2343     variable filesMade
2344     variable filesExisted
2345     variable createdNewFiles
2346     variable testSingleFile
2347     variable numTests
2348     variable numTestFiles
2349     variable failFiles
2350     variable skippedBecause
2351     variable currentFailure
2352     variable originalEnv
2353     variable originalTclPlatform
2354     variable coreModTime
2355
2356     FillFilesExisted
2357     set testFileName [file tail [info script]]
2358
2359     # Call the cleanup hook
2360     cleanupTestsHook
2361
2362     # Remove files and directories created by the makeFile and
2363     # makeDirectory procedures.  Record the names of files in
2364     # workingDirectory that were not pre-existing, and associate them
2365     # with the test file that created them.
2366
2367     if {!$calledFromAllFile} {
2368         foreach file $filesMade {
2369             if {[file exists $file]} {
2370                 DebugDo 1 {Warn "cleanupTests deleting $file..."}
2371                 catch {file delete -force $file}
2372             }
2373         }
2374         set currentFiles {}
2375         foreach file [glob -nocomplain \
2376                 -directory [temporaryDirectory] *] {
2377             lappend currentFiles [file tail $file]
2378         }
2379         set newFiles {}
2380         foreach file $currentFiles {
2381             if {[lsearch -exact $filesExisted $file] == -1} {
2382                 lappend newFiles $file
2383             }
2384         }
2385         set filesExisted $currentFiles
2386         if {[llength $newFiles] > 0} {
2387             set createdNewFiles($testFileName) $newFiles
2388         }
2389     }
2390
2391     if {$calledFromAllFile || $testSingleFile} {
2392
2393         # print stats
2394
2395         puts -nonewline [outputChannel] "$testFileName:"
2396         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2397             puts -nonewline [outputChannel] \
2398                     "\t$index\t$numTests($index)"
2399         }
2400         puts [outputChannel] ""
2401
2402         # print number test files sourced
2403         # print names of files that ran tests which failed
2404
2405         if {$calledFromAllFile} {
2406             puts [outputChannel] \
2407                     "Sourced $numTestFiles Test Files."
2408             set numTestFiles 0
2409             if {[llength $failFiles] > 0} {
2410                 puts [outputChannel] \
2411                         "Files with failing tests: $failFiles"
2412                 set failFiles {}
2413             }
2414         }
2415
2416         # if any tests were skipped, print the constraints that kept
2417         # them from running.
2418
2419         set constraintList [array names skippedBecause]
2420         if {[llength $constraintList] > 0} {
2421             puts [outputChannel] \
2422                     "Number of tests skipped for each constraint:"
2423             foreach constraint [lsort $constraintList] {
2424                 puts [outputChannel] \
2425                         "\t$skippedBecause($constraint)\t$constraint"
2426                 unset skippedBecause($constraint)
2427             }
2428         }
2429
2430         # report the names of test files in createdNewFiles, and reset
2431         # the array to be empty.
2432
2433         set testFilesThatTurded [lsort [array names createdNewFiles]]
2434         if {[llength $testFilesThatTurded] > 0} {
2435             puts [outputChannel] "Warning: files left behind:"
2436             foreach testFile $testFilesThatTurded {
2437                 puts [outputChannel] \
2438                         "\t$testFile:\t$createdNewFiles($testFile)"
2439                 unset createdNewFiles($testFile)
2440             }
2441         }
2442
2443         # reset filesMade, filesExisted, and numTests
2444
2445         set filesMade {}
2446         foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2447             set numTests($index) 0
2448         }
2449
2450         # exit only if running Tk in non-interactive mode
2451         # This should be changed to determine if an event
2452         # loop is running, which is the real issue.
2453         # Actually, this doesn't belong here at all.  A package
2454         # really has no business [exit]-ing an application.
2455         if {![catch {package present Tk}] && ![testConstraint interactive]} {
2456             exit
2457         }
2458     } else {
2459
2460         # if we're deferring stat-reporting until all files are sourced,
2461         # then add current file to failFile list if any tests in this
2462         # file failed
2463
2464         if {$currentFailure \
2465                 && ([lsearch -exact $failFiles $testFileName] == -1)} {
2466             lappend failFiles $testFileName
2467         }
2468         set currentFailure false
2469
2470         # restore the environment to the state it was in before this package
2471         # was loaded
2472
2473         set newEnv {}
2474         set changedEnv {}
2475         set removedEnv {}
2476         foreach index [array names ::env] {
2477             if {![info exists originalEnv($index)]} {
2478                 lappend newEnv $index
2479                 unset ::env($index)
2480             } else {
2481                 if {$::env($index) != $originalEnv($index)} {
2482                     lappend changedEnv $index
2483                     set ::env($index) $originalEnv($index)
2484                 }
2485             }
2486         }
2487         foreach index [array names originalEnv] {
2488             if {![info exists ::env($index)]} {
2489                 lappend removedEnv $index
2490                 set ::env($index) $originalEnv($index)
2491             }
2492         }
2493         if {[llength $newEnv] > 0} {
2494             puts [outputChannel] \
2495                     "env array elements created:\t$newEnv"
2496         }
2497         if {[llength $changedEnv] > 0} {
2498             puts [outputChannel] \
2499                     "env array elements changed:\t$changedEnv"
2500         }
2501         if {[llength $removedEnv] > 0} {
2502             puts [outputChannel] \
2503                     "env array elements removed:\t$removedEnv"
2504         }
2505
2506         set changedTclPlatform {}
2507         foreach index [array names originalTclPlatform] {
2508             if {$::tcl_platform($index) \
2509                     != $originalTclPlatform($index)} {
2510                 lappend changedTclPlatform $index
2511                 set ::tcl_platform($index) $originalTclPlatform($index)
2512             }
2513         }
2514         if {[llength $changedTclPlatform] > 0} {
2515             puts [outputChannel] "tcl_platform array elements\
2516                     changed:\t$changedTclPlatform"
2517         }
2518
2519         if {[file exists [file join [workingDirectory] core]]} {
2520             if {[preserveCore] > 1} {
2521                 puts "rename core file (> 1)"
2522                 puts [outputChannel] "produced core file! \
2523                         Moving file to: \
2524                         [file join [temporaryDirectory] core-$testFileName]"
2525                 catch {file rename -force \
2526                         [file join [workingDirectory] core] \
2527                         [file join [temporaryDirectory] core-$testFileName]
2528                 } msg
2529                 if {[string length $msg] > 0} {
2530                     PrintError "Problem renaming file: $msg"
2531                 }
2532             } else {
2533                 # Print a message if there is a core file and (1) there
2534                 # previously wasn't one or (2) the new one is different
2535                 # from the old one.
2536
2537                 if {[info exists coreModTime]} {
2538                     if {$coreModTime != [file mtime \
2539                             [file join [workingDirectory] core]]} {
2540                         puts [outputChannel] "A core file was created!"
2541                     }
2542                 } else {
2543                     puts [outputChannel] "A core file was created!"
2544                 }
2545             }
2546         }
2547     }
2548     flush [outputChannel]
2549     flush [errorChannel]
2550     return
2551 }
2552
2553 #####################################################################
2554
2555 # Procs that determine which tests/test files to run
2556
2557 # tcltest::GetMatchingFiles
2558 #
2559 #       Looks at the patterns given to match and skip files and uses
2560 #       them to put together a list of the tests that will be run.
2561 #
2562 # Arguments:
2563 #       directory to search
2564 #
2565 # Results:
2566 #       The constructed list is returned to the user.  This will
2567 #       primarily be used in 'all.tcl' files.  It is used in
2568 #       runAllTests.
2569 #
2570 # Side Effects:
2571 #       None
2572
2573 # a lower case version is needed for compatibility with tcltest 1.0
2574 proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
2575
2576 proc tcltest::GetMatchingFiles { args } {
2577     if {[llength $args]} {
2578         set dirList $args
2579     } else {
2580         # Finding tests only in [testsDirectory] is normal operation.
2581         # This procedure is written to accept multiple directory arguments
2582         # only to satisfy version 1 compatibility.
2583         set dirList [list [testsDirectory]]
2584     }
2585
2586     set matchingFiles [list]
2587     foreach directory $dirList {
2588
2589         # List files in $directory that match patterns to run.
2590         set matchFileList [list]
2591         foreach match [matchFiles] {
2592             set matchFileList [concat $matchFileList \
2593                     [glob -directory $directory -types {b c f p s} \
2594                     -nocomplain -- $match]]
2595         }
2596
2597         # List files in $directory that match patterns to skip.
2598         set skipFileList [list]
2599         foreach skip [skipFiles] {
2600             set skipFileList [concat $skipFileList \
2601                     [glob -directory $directory -types {b c f p s} \
2602                     -nocomplain -- $skip]]
2603         }
2604
2605         # Add to result list all files in match list and not in skip list
2606         foreach file $matchFileList {
2607             if {[lsearch -exact $skipFileList $file] == -1} {
2608                 lappend matchingFiles $file
2609             }
2610         }
2611     }
2612
2613     if {[llength $matchingFiles] == 0} {
2614         PrintError "No test files remain after applying your match and\
2615                 skip patterns!"
2616     }
2617     return $matchingFiles
2618 }
2619
2620 # tcltest::GetMatchingDirectories --
2621 #
2622 #       Looks at the patterns given to match and skip directories and
2623 #       uses them to put together a list of the test directories that we
2624 #       should attempt to run.  (Only subdirectories containing an
2625 #       "all.tcl" file are put into the list.)
2626 #
2627 # Arguments:
2628 #       root directory from which to search
2629 #
2630 # Results:
2631 #       The constructed list is returned to the user.  This is used in
2632 #       the primary all.tcl file.
2633 #
2634 # Side Effects:
2635 #       None.
2636
2637 proc tcltest::GetMatchingDirectories {rootdir} {
2638
2639     # Determine the skip list first, to avoid [glob]-ing over subdirectories
2640     # we're going to throw away anyway.  Be sure we skip the $rootdir if it
2641     # comes up to avoid infinite loops.
2642     set skipDirs [list $rootdir]
2643     foreach pattern [skipDirectories] {
2644         set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
2645                 -nocomplain -- $pattern]]
2646     }
2647
2648     # Now step through the matching directories, prune out the skipped ones
2649     # as you go.
2650     set matchDirs [list]
2651     foreach pattern [matchDirectories] {
2652         foreach path [glob -directory $rootdir -types d -nocomplain -- \
2653                 $pattern] {
2654             if {[lsearch -exact $skipDirs $path] == -1} {
2655                 set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
2656                 if {[file exists [file join $path all.tcl]]} {
2657                     lappend matchDirs $path
2658                 }
2659             }
2660         }
2661     }
2662
2663     if {[llength $matchDirs] == 0} {
2664         DebugPuts 1 "No test directories remain after applying match\
2665                 and skip patterns!"
2666     }
2667     return $matchDirs
2668 }
2669
2670 # tcltest::runAllTests --
2671 #
2672 #       prints output and sources test files according to the match and
2673 #       skip patterns provided.  after sourcing test files, it goes on
2674 #       to source all.tcl files in matching test subdirectories.
2675 #
2676 # Arguments:
2677 #       shell being tested
2678 #
2679 # Results:
2680 #       None.
2681 #
2682 # Side effects:
2683 #       None.
2684
2685 proc tcltest::runAllTests { {shell ""} } {
2686     variable testSingleFile
2687     variable numTestFiles
2688     variable numTests
2689     variable failFiles
2690
2691     FillFilesExisted
2692     if {[llength [info level 0]] == 1} {
2693         set shell [interpreter]
2694     }
2695
2696     set testSingleFile false
2697
2698     puts [outputChannel] "Tests running in interp:  $shell"
2699     puts [outputChannel] "Tests located in:  [testsDirectory]"
2700     puts [outputChannel] "Tests running in:  [workingDirectory]"
2701     puts [outputChannel] "Temporary files stored in\
2702             [temporaryDirectory]"
2703
2704     # [file system] first available in Tcl 8.4
2705     if {![catch {file system [testsDirectory]} result]
2706             && ![string equal native [lindex $result 0]]} {
2707         # If we aren't running in the native filesystem, then we must
2708         # run the tests in a single process (via 'source'), because
2709         # trying to run then via a pipe will fail since the files don't
2710         # really exist.
2711         singleProcess 1
2712     }
2713
2714     if {[singleProcess]} {
2715         puts [outputChannel] \
2716                 "Test files sourced into current interpreter"
2717     } else {
2718         puts [outputChannel] \
2719                 "Test files run in separate interpreters"
2720     }
2721     if {[llength [skip]] > 0} {
2722         puts [outputChannel] "Skipping tests that match:  [skip]"
2723     }
2724     puts [outputChannel] "Running tests that match:  [match]"
2725
2726     if {[llength [skipFiles]] > 0} {
2727         puts [outputChannel] \
2728                 "Skipping test files that match:  [skipFiles]"
2729     }
2730     if {[llength [matchFiles]] > 0} {
2731         puts [outputChannel] \
2732                 "Only running test files that match:  [matchFiles]"
2733     }
2734
2735     set timeCmd {clock format [clock seconds]}
2736     puts [outputChannel] "Tests began at [eval $timeCmd]"
2737
2738     # Run each of the specified tests
2739     foreach file [lsort [GetMatchingFiles]] {
2740         set tail [file tail $file]
2741         puts [outputChannel] $tail
2742         flush [outputChannel]
2743
2744         if {[singleProcess]} {
2745             incr numTestFiles
2746             uplevel 1 [list ::source $file]
2747         } else {
2748             # Pass along our configuration to the child processes.
2749             # EXCEPT for the -outfile, because the parent process
2750             # needs to read and process output of children.
2751             set childargv [list]
2752             foreach opt [Configure] {
2753                 if {[string equal $opt -outfile]} {continue}
2754                 lappend childargv $opt [Configure $opt]
2755             }
2756             set cmd [linsert $childargv 0 | $shell $file]
2757             if {[catch {
2758                 incr numTestFiles
2759                 set pipeFd [open $cmd "r"]
2760                 while {[gets $pipeFd line] >= 0} {
2761                     if {[regexp [join {
2762                             {^([^:]+):\t}
2763                             {Total\t([0-9]+)\t}
2764                             {Passed\t([0-9]+)\t}
2765                             {Skipped\t([0-9]+)\t}
2766                             {Failed\t([0-9]+)}
2767                             } ""] $line null testFile \
2768                             Total Passed Skipped Failed]} {
2769                         foreach index {Total Passed Skipped Failed} {
2770                             incr numTests($index) [set $index]
2771                         }
2772                         if {$Failed > 0} {
2773                             lappend failFiles $testFile
2774                         }
2775                     } elseif {[regexp [join {
2776                             {^Number of tests skipped }
2777                             {for each constraint:}
2778                             {|^\t(\d+)\t(.+)$}
2779                             } ""] $line match skipped constraint]} {
2780                         if {[string match \t* $match]} {
2781                             AddToSkippedBecause $constraint $skipped
2782                         }
2783                     } else {
2784                         puts [outputChannel] $line
2785                     }
2786                 }
2787                 close $pipeFd
2788             } msg]} {
2789                 puts [outputChannel] "Test file error: $msg"
2790                 # append the name of the test to a list to be reported
2791                 # later
2792                 lappend testFileFailures $file
2793             }
2794         }
2795     }
2796
2797     # cleanup
2798     puts [outputChannel] "\nTests ended at [eval $timeCmd]"
2799     cleanupTests 1
2800     if {[info exists testFileFailures]} {
2801         puts [outputChannel] "\nTest files exiting with errors:  \n"
2802         foreach file $testFileFailures {
2803             puts [outputChannel] "  [file tail $file]\n"
2804         }
2805     }
2806
2807     # Checking for subdirectories in which to run tests
2808     foreach directory [GetMatchingDirectories [testsDirectory]] {
2809         set dir [file tail $directory]
2810         puts [outputChannel] [string repeat ~ 44]
2811         puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
2812
2813         uplevel 1 [list ::source [file join $directory all.tcl]]
2814
2815         set endTime [eval $timeCmd]
2816         puts [outputChannel] "\n$dir test ended at $endTime"
2817         puts [outputChannel] ""
2818         puts [outputChannel] [string repeat ~ 44]
2819     }
2820     return
2821 }
2822
2823 #####################################################################
2824
2825 # Test utility procs - not used in tcltest, but may be useful for
2826 # testing.
2827
2828 # tcltest::loadTestedCommands --
2829 #
2830 #     Uses the specified script to load the commands to test. Allowed to
2831 #     be empty, as the tested commands could have been compiled into the
2832 #     interpreter.
2833 #
2834 # Arguments
2835 #     none
2836 #
2837 # Results
2838 #     none
2839 #
2840 # Side Effects:
2841 #     none.
2842
2843 proc tcltest::loadTestedCommands {} {
2844     variable l
2845     if {[string equal {} [loadScript]]} {
2846         return
2847     }
2848
2849     return [uplevel 1 [loadScript]]
2850 }
2851
2852 # tcltest::saveState --
2853 #
2854 #       Save information regarding what procs and variables exist.
2855 #
2856 # Arguments:
2857 #       none
2858 #
2859 # Results:
2860 #       Modifies the variable saveState
2861 #
2862 # Side effects:
2863 #       None.
2864
2865 proc tcltest::saveState {} {
2866     variable saveState
2867     uplevel 1 [list ::set [namespace which -variable saveState]] \
2868             {[::list [::info procs] [::info vars]]}
2869     DebugPuts  2 "[lindex [info level 0] 0]: $saveState"
2870     return
2871 }
2872
2873 # tcltest::restoreState --
2874 #
2875 #       Remove procs and variables that didn't exist before the call to
2876 #       [saveState].
2877 #
2878 # Arguments:
2879 #       none
2880 #
2881 # Results:
2882 #       Removes procs and variables from your environment if they don't
2883 #       exist in the saveState variable.
2884 #
2885 # Side effects:
2886 #       None.
2887
2888 proc tcltest::restoreState {} {
2889     variable saveState
2890     foreach p [uplevel 1 {::info procs}] {
2891         if {([lsearch [lindex $saveState 0] $p] < 0)
2892                 && ![string equal [namespace current]::$p \
2893                 [uplevel 1 [list ::namespace origin $p]]]} {
2894
2895             DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
2896             uplevel 1 [list ::catch [list ::rename $p {}]]
2897         }
2898     }
2899     foreach p [uplevel 1 {::info vars}] {
2900         if {[lsearch [lindex $saveState 1] $p] < 0} {
2901             DebugPuts 2 "[lindex [info level 0] 0]:\
2902                     Removing variable $p"
2903             uplevel 1 [list ::catch [list ::unset $p]]
2904         }
2905     }
2906     return
2907 }
2908
2909 # tcltest::normalizeMsg --
2910 #
2911 #       Removes "extra" newlines from a string.
2912 #
2913 # Arguments:
2914 #       msg        String to be modified
2915 #
2916 # Results:
2917 #       string with extra newlines removed
2918 #
2919 # Side effects:
2920 #       None.
2921
2922 proc tcltest::normalizeMsg {msg} {
2923     regsub "\n$" [string tolower $msg] "" msg
2924     set msg [string map [list "\n\n" "\n"] $msg]
2925     return [string map [list "\n\}" "\}"] $msg]
2926 }
2927
2928 # tcltest::makeFile --
2929 #
2930 # Create a new file with the name <name>, and write <contents> to it.
2931 #
2932 # If this file hasn't been created via makeFile since the last time
2933 # cleanupTests was called, add it to the $filesMade list, so it will be
2934 # removed by the next call to cleanupTests.
2935 #
2936 # Arguments:
2937 #       contents        content of the new file
2938 #       name            name of the new file
2939 #       directory       directory name for new file
2940 #
2941 # Results:
2942 #       absolute path to the file created
2943 #
2944 # Side effects:
2945 #       None.
2946
2947 proc tcltest::makeFile {contents name {directory ""}} {
2948     variable filesMade
2949     FillFilesExisted
2950
2951     if {[llength [info level 0]] == 3} {
2952         set directory [temporaryDirectory]
2953     }
2954
2955     set fullName [file join $directory $name]
2956
2957     DebugPuts 3 "[lindex [info level 0] 0]:\
2958              putting ``$contents'' into $fullName"
2959
2960     set fd [open $fullName w]
2961     fconfigure $fd -translation lf
2962     if {[string equal [string index $contents end] \n]} {
2963         puts -nonewline $fd $contents
2964     } else {
2965         puts $fd $contents
2966     }
2967     close $fd
2968
2969     if {[lsearch -exact $filesMade $fullName] == -1} {
2970         lappend filesMade $fullName
2971     }
2972     return $fullName
2973 }
2974
2975 # tcltest::removeFile --
2976 #
2977 #       Removes the named file from the filesystem
2978 #
2979 # Arguments:
2980 #       name          file to be removed
2981 #       directory     directory from which to remove file
2982 #
2983 # Results:
2984 #       return value from [file delete]
2985 #
2986 # Side effects:
2987 #       None.
2988
2989 proc tcltest::removeFile {name {directory ""}} {
2990     variable filesMade
2991     FillFilesExisted
2992     if {[llength [info level 0]] == 2} {
2993         set directory [temporaryDirectory]
2994     }
2995     set fullName [file join $directory $name]
2996     DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
2997     set idx [lsearch -exact $filesMade $fullName]
2998     set filesMade [lreplace $filesMade $idx $idx]
2999     if {$idx == -1} {
3000         DebugDo 1 {
3001             Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
3002         }
3003     }
3004     if {![file isfile $fullName]} {
3005         DebugDo 1 {
3006             Warn "removeFile removing \"$fullName\":\n  not a file"
3007         }
3008     }
3009     return [file delete $fullName]
3010 }
3011
3012 # tcltest::makeDirectory --
3013 #
3014 # Create a new dir with the name <name>.
3015 #
3016 # If this dir hasn't been created via makeDirectory since the last time
3017 # cleanupTests was called, add it to the $directoriesMade list, so it
3018 # will be removed by the next call to cleanupTests.
3019 #
3020 # Arguments:
3021 #       name            name of the new directory
3022 #       directory       directory in which to create new dir
3023 #
3024 # Results:
3025 #       absolute path to the directory created
3026 #
3027 # Side effects:
3028 #       None.
3029
3030 proc tcltest::makeDirectory {name {directory ""}} {
3031     variable filesMade
3032     FillFilesExisted
3033     if {[llength [info level 0]] == 2} {
3034         set directory [temporaryDirectory]
3035     }
3036     set fullName [file join $directory $name]
3037     DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
3038     file mkdir $fullName
3039     if {[lsearch -exact $filesMade $fullName] == -1} {
3040         lappend filesMade $fullName
3041     }
3042     return $fullName
3043 }
3044
3045 # tcltest::removeDirectory --
3046 #
3047 #       Removes a named directory from the file system.
3048 #
3049 # Arguments:
3050 #       name          Name of the directory to remove
3051 #       directory     Directory from which to remove
3052 #
3053 # Results:
3054 #       return value from [file delete]
3055 #
3056 # Side effects:
3057 #       None
3058
3059 proc tcltest::removeDirectory {name {directory ""}} {
3060     variable filesMade
3061     FillFilesExisted
3062     if {[llength [info level 0]] == 2} {
3063         set directory [temporaryDirectory]
3064     }
3065     set fullName [file join $directory $name]
3066     DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
3067     set idx [lsearch -exact $filesMade $fullName]
3068     set filesMade [lreplace $filesMade $idx $idx]
3069     if {$idx == -1} {
3070         DebugDo 1 {
3071             Warn "removeDirectory removing \"$fullName\":\n  not created\
3072                     by makeDirectory"
3073         }
3074     }
3075     if {![file isdirectory $fullName]} {
3076         DebugDo 1 {
3077             Warn "removeDirectory removing \"$fullName\":\n  not a directory"
3078         }
3079     }
3080     return [file delete -force $fullName]
3081 }
3082
3083 # tcltest::viewFile --
3084 #
3085 #       reads the content of a file and returns it
3086 #
3087 # Arguments:
3088 #       name of the file to read
3089 #       directory in which file is located
3090 #
3091 # Results:
3092 #       content of the named file
3093 #
3094 # Side effects:
3095 #       None.
3096
3097 proc tcltest::viewFile {name {directory ""}} {
3098     FillFilesExisted
3099     if {[llength [info level 0]] == 2} {
3100         set directory [temporaryDirectory]
3101     }
3102     set fullName [file join $directory $name]
3103     set f [open $fullName]
3104     set data [read -nonewline $f]
3105     close $f
3106     return $data
3107 }
3108
3109 # tcltest::bytestring --
3110 #
3111 # Construct a string that consists of the requested sequence of bytes,
3112 # as opposed to a string of properly formed UTF-8 characters.
3113 # This allows the tester to
3114 # 1. Create denormalized or improperly formed strings to pass to C
3115 #    procedures that are supposed to accept strings with embedded NULL
3116 #    bytes.
3117 # 2. Confirm that a string result has a certain pattern of bytes, for
3118 #    instance to confirm that "\xe0\0" in a Tcl script is stored
3119 #    internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
3120 #
3121 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
3122 # construct improperly formed strings in this manner, because it involves
3123 # exposing that Tcl uses UTF-8 internally.
3124 #
3125 # Arguments:
3126 #       string being converted
3127 #
3128 # Results:
3129 #       result fom encoding
3130 #
3131 # Side effects:
3132 #       None
3133
3134 proc tcltest::bytestring {string} {
3135     return [encoding convertfrom identity $string]
3136 }
3137
3138 # tcltest::OpenFiles --
3139 #
3140 #       used in io tests, uses testchannel
3141 #
3142 # Arguments:
3143 #       None.
3144 #
3145 # Results:
3146 #       ???
3147 #
3148 # Side effects:
3149 #       None.
3150
3151 proc tcltest::OpenFiles {} {
3152     if {[catch {testchannel open} result]} {
3153         return {}
3154     }
3155     return $result
3156 }
3157
3158 # tcltest::LeakFiles --
3159 #
3160 #       used in io tests, uses testchannel
3161 #
3162 # Arguments:
3163 #       None.
3164 #
3165 # Results:
3166 #       ???
3167 #
3168 # Side effects:
3169 #       None.
3170
3171 proc tcltest::LeakFiles {old} {
3172     if {[catch {testchannel open} new]} {
3173         return {}
3174     }
3175     set leak {}
3176     foreach p $new {
3177         if {[lsearch $old $p] < 0} {
3178             lappend leak $p
3179         }
3180     }
3181     return $leak
3182 }
3183
3184 #
3185 # Internationalization / ISO support procs     -- dl
3186 #
3187
3188 # tcltest::SetIso8859_1_Locale --
3189 #
3190 #       used in cmdIL.test, uses testlocale
3191 #
3192 # Arguments:
3193 #       None.
3194 #
3195 # Results:
3196 #       None.
3197 #
3198 # Side effects:
3199 #       None.
3200
3201 proc tcltest::SetIso8859_1_Locale {} {
3202     variable previousLocale
3203     variable isoLocale
3204     if {[info commands testlocale] != ""} {
3205         set previousLocale [testlocale ctype]
3206         testlocale ctype $isoLocale
3207     }
3208     return
3209 }
3210
3211 # tcltest::RestoreLocale --
3212 #
3213 #       used in cmdIL.test, uses testlocale
3214 #
3215 # Arguments:
3216 #       None.
3217 #
3218 # Results:
3219 #       None.
3220 #
3221 # Side effects:
3222 #       None.
3223
3224 proc tcltest::RestoreLocale {} {
3225     variable previousLocale
3226     if {[info commands testlocale] != ""} {
3227         testlocale ctype $previousLocale
3228     }
3229     return
3230 }
3231
3232 # tcltest::threadReap --
3233 #
3234 #       Kill all threads except for the main thread.
3235 #       Do nothing if testthread is not defined.
3236 #
3237 # Arguments:
3238 #       none.
3239 #
3240 # Results:
3241 #       Returns the number of existing threads.
3242 #
3243 # Side Effects:
3244 #       none.
3245 #
3246
3247 proc tcltest::threadReap {} {
3248     if {[info commands testthread] != {}} {
3249
3250         # testthread built into tcltest
3251
3252         testthread errorproc ThreadNullError
3253         while {[llength [testthread names]] > 1} {
3254             foreach tid [testthread names] {
3255                 if {$tid != [mainThread]} {
3256                     catch {
3257                         testthread send -async $tid {testthread exit}
3258                     }
3259                 }
3260             }
3261             ## Enter a bit a sleep to give the threads enough breathing
3262             ## room to kill themselves off, otherwise the end up with a
3263             ## massive queue of repeated events
3264             after 1
3265         }
3266         testthread errorproc ThreadError
3267         return [llength [testthread names]]
3268     } elseif {[info commands thread::id] != {}} {
3269
3270         # Thread extension
3271
3272         thread::errorproc ThreadNullError
3273         while {[llength [thread::names]] > 1} {
3274             foreach tid [thread::names] {
3275                 if {$tid != [mainThread]} {
3276                     catch {thread::send -async $tid {thread::exit}}
3277                 }
3278             }
3279             ## Enter a bit a sleep to give the threads enough breathing
3280             ## room to kill themselves off, otherwise the end up with a
3281             ## massive queue of repeated events
3282             after 1
3283         }
3284         thread::errorproc ThreadError
3285         return [llength [thread::names]]
3286     } else {
3287         return 1
3288     }
3289     return 0
3290 }
3291
3292 # Initialize the constraints and set up command line arguments
3293 namespace eval tcltest {
3294     # Define initializers for all the built-in contraint definitions
3295     DefineConstraintInitializers
3296
3297     # Set up the constraints in the testConstraints array to be lazily
3298     # initialized by a registered initializer, or by "false" if no
3299     # initializer is registered.
3300     trace variable testConstraints r [namespace code SafeFetch]
3301
3302     # Only initialize constraints at package load time if an
3303     # [initConstraintsHook] has been pre-defined.  This is only
3304     # for compatibility support.  The modern way to add a custom
3305     # test constraint is to just call the [testConstraint] command
3306     # straight away, without all this "hook" nonsense.
3307     if {[string equal [namespace current] \
3308             [namespace qualifiers [namespace which initConstraintsHook]]]} {
3309         InitConstraints
3310     } else {
3311         proc initConstraintsHook {} {}
3312     }
3313
3314     # Define the standard match commands
3315     customMatch exact   [list string equal]
3316     customMatch glob    [list string match]
3317     customMatch regexp  [list regexp --]
3318
3319     # If the TCLTEST_OPTIONS environment variable exists, configure
3320     # tcltest according to the option values it specifies.  This has
3321     # the effect of resetting tcltest's default configuration.
3322     proc ConfigureFromEnvironment {} {
3323         upvar #0 env(TCLTEST_OPTIONS) options
3324         if {[catch {llength $options} msg]} {
3325             Warn "invalid TCLTEST_OPTIONS \"$options\":\n  invalid\
3326                     Tcl list: $msg"
3327             return
3328         }
3329         if {[llength $options] % 2} {
3330             Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  should be\
3331                     -option value ?-option value ...?"
3332             return
3333         }
3334         if {[catch {Configure {*}$options} msg]} {
3335             Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  $msg"
3336             return
3337         }
3338     }
3339     if {[info exists ::env(TCLTEST_OPTIONS)]} {
3340         ConfigureFromEnvironment
3341     }
3342
3343     proc LoadTimeCmdLineArgParsingRequired {} {
3344         set required false
3345         if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
3346             # The command line asks for -help, so give it (and exit)
3347             # right now.  ([configure] does not process -help)
3348             set required true
3349         }
3350         foreach hook { PrintUsageInfoHook processCmdLineArgsHook
3351                         processCmdLineArgsAddFlagsHook } {
3352             if {[string equal [namespace current] [namespace qualifiers \
3353                     [namespace which $hook]]]} {
3354                 set required true
3355             } else {
3356                 proc $hook args {}
3357             }
3358         }
3359         return $required
3360     }
3361
3362     # Only initialize configurable options from the command line arguments
3363     # at package load time if necessary for backward compatibility.  This
3364     # lets the tcltest user call [configure] for themselves if they wish.
3365     # Traces are established for auto-configuration from the command line
3366     # if any configurable options are accessed before the user calls
3367     # [configure].
3368     if {[LoadTimeCmdLineArgParsingRequired]} {
3369         ProcessCmdLineArgs
3370     } else {
3371         EstablishAutoConfigureTraces
3372     }
3373
3374     package provide [namespace tail [namespace current]] $Version
3375 }