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