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
9 # This design was based on the Tcl testing approach designed and
10 # initially implemented by Mary Ann May-Pumphrey of Sun
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.
19 package require Tcl 8.5 ;# -verbose line uses [info frame]
20 namespace eval tcltest {
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.4
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]
33 ##### Export the public tcltest procs; several categories
35 # Export the main functional commands that do useful things
36 namespace export cleanupTests loadTestedCommands makeDirectory \
37 makeFile removeDirectory removeFile runAllTests test
39 # Export configuration commands that control the functional commands
40 namespace export configure customMatch errorChannel interpreter \
41 outputChannel testConstraint
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]
67 # Export deprecated commands for tcltest 1 compatibility
68 namespace export getMatchingFiles mainThread restoreState saveState \
71 # tcltest::normalizePath --
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.
78 # pathVar - name of variable containing path to modify.
81 # The path is modified in place.
86 proc normalizePath {pathVar} {
95 ##### Verification commands used to test values of variables and options
97 # Verification command that accepts everything
98 proc AcceptAll {value} {
102 # Verification command that accepts valid Tcl lists
103 proc AcceptList { list } {
104 return [lrange $list 0 end]
107 # Verification command that accepts a glob pattern
108 proc AcceptPattern { pattern } {
109 return [AcceptAll $pattern]
112 # Verification command that accepts integers
113 proc AcceptInteger { level } {
114 return [incr level 0]
117 # Verification command that accepts boolean values
118 proc AcceptBoolean { boolean } {
119 return [expr {$boolean && $boolean}]
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"
130 # Verification command that accepts (converts to) absolute pathnames
131 proc AcceptAbsolutePath { path } {
132 return [file join [pwd] $path]
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"
142 proc AcceptDirectory { directory } {
143 set directory [AcceptAbsolutePath $directory]
144 if {![file exists $directory]} {
145 return -code error "\"$directory\" does not exist"
147 if {![file isdir $directory]} {
148 return -code error "\"$directory\" is not a directory"
150 return [AcceptReadable $directory]
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.
158 proc ArrayDefault {varName value} {
160 if {[array exists $varName]} {
163 if {[info exists $varName]} {
164 # Pre-initialized value is a scalar: destroy it!
167 array set $varName $value
170 # save the original environment so that it can be restored later
171 ArrayDefault originalEnv [array get ::env]
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]
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
180 ArrayDefault createdNewFiles {}
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
189 ArrayDefault skippedBecause {}
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 {}
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.
201 proc Default {varName value {verify AcceptAll}} {
203 if {![info exists $varName]} {
204 variable $varName [$verify $value]
206 variable $varName [$verify [set $varName]]
210 # Save any arguments that we might want to pass through to other
211 # programs. This is used by the -args flag.
213 Default parameters {}
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
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.
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
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]
244 # After successful filling, turn this into a no-op.
245 proc FillFilesExisted args {}
248 # Kept only for compatibility
249 Default constraintsSpecified {} AcceptList
250 trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \
251 [array names ::tcltest::testConstraints] ;# }
253 # tests that use threads need to know which is the main thread
256 if {[info commands thread::id] != {}} {
257 set mainThread [thread::id]
258 } elseif {[info commands testthread] != {}} {
259 set mainThread [testthread id]
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 variable workingDirectory w \
267 [namespace code {cd $workingDirectory ;#}]
269 Default workingDirectory [pwd] AcceptAbsolutePath
270 proc workingDirectory { {dir ""} } {
271 variable workingDirectory
272 if {[llength [info level 0]] == 1} {
273 return $workingDirectory
275 set workingDirectory [AcceptAbsolutePath $dir]
278 # Set the location of the execuatble
279 Default tcltest [info nameofexecutable]
280 trace variable tcltest w [namespace code {testConstraint stdio \
281 [eval [ConstraintInitializer stdio]] ;#}]
283 # save the platform information so it can be restored later
284 Default originalTclPlatform [array get ::tcl_platform]
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]]
292 # stdout and stderr buffers for use when we want to store them
296 # keep track of test level for nested test commands
299 # the variables and procs that existed when saveState was called are
300 # stored in a variable of the same name
303 # Internationalization support -- used in [SetIso8859_1_Locale] and
304 # [RestoreLocale]. Those commands are used in cmdIL.test.
306 if {![info exists [namespace current]::isoLocale]} {
307 variable isoLocale fr
308 switch -- $::tcl_platform(platform) {
311 # Try some 'known' values for some platforms:
313 switch -exact -- $::tcl_platform(os) {
315 set isoLocale fr_FR.ISO_8859-1
318 set isoLocale fr_FR.iso88591
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.
330 set isoLocale iso_8859_1
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
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 :) )
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
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].
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,
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
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.
386 if {[llength [info level 0]] == 1} {
387 return $outputChannel
389 if {[info exists ChannelsWeOpened($outputChannel)]} {
391 unset ChannelsWeOpened($outputChannel)
393 switch -exact -- $filename {
396 set outputChannel $filename
399 set outputChannel [open $filename a]
400 set ChannelsWeOpened($outputChannel) 1
402 # If we created the file in [temporaryDirectory], then
403 # [cleanupTests] will delete it, unless we claim it was
405 set outdir [normalizePath [file dirname \
406 [file join [pwd] $filename]]]
407 if {[string equal $outdir [temporaryDirectory]]} {
408 variable filesExisted
410 set filename [file tail $filename]
411 if {[lsearch -exact $filesExisted $filename] == -1} {
412 lappend filesExisted $filename
417 return $outputChannel
420 # errors go to stderr by default
421 Default errorChannel stderr
422 proc errorChannel { {filename ""} } {
423 variable errorChannel
424 variable ChannelsWeOpened
426 # This is subtle and tricky. See the comment above in
427 # [outputChannel] for a detailed explanation.
430 if {[llength [info level 0]] == 1} {
433 if {[info exists ChannelsWeOpened($errorChannel)]} {
435 unset ChannelsWeOpened($errorChannel)
437 switch -exact -- $filename {
440 set errorChannel $filename
443 set errorChannel [open $filename a]
444 set ChannelsWeOpened($errorChannel) 1
446 # If we created the file in [temporaryDirectory], then
447 # [cleanupTests] will delete it, unless we claim it was
449 set outdir [normalizePath [file dirname \
450 [file join [pwd] $filename]]]
451 if {[string equal $outdir [temporaryDirectory]]} {
452 variable filesExisted
454 set filename [file tail $filename]
455 if {[lsearch -exact $filesExisted $filename] == -1} {
456 lappend filesExisted $filename
464 ##### Set up the configurable options
466 # The configurable options of the package
467 variable Option; array set Option {}
469 # Usage strings for those options
470 variable Usage; array set Usage {}
472 # Verification commands for those options
473 variable Verify; array set Verify {}
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 {}}} {
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
493 set Option($option) $msg
495 if {[string length $varName]} {
497 if {[info exists $varName]} {
498 if {[catch {$verify [set $varName]} msg]} {
499 return -code error $msg
501 set Option($option) $msg
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]
516 return [Configure $option]
521 proc MatchingOption {option} {
523 set match [array names Option $option*]
524 switch -- [llength $match] {
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\
533 return [lindex $match 0]
536 # Exact match trumps ambiguity
537 if {[lsearch -exact $match $option] >= 0} {
540 set values [join [lrange $match 0 end-1] ", "]
541 append values ", or [lindex $match end]"
542 return -code error "ambiguous option $option:\
548 proc EstablishAutoConfigureTraces {} {
549 variable OptionControlledVariables
550 foreach varName [concat $OptionControlledVariables Option] {
552 trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
556 proc RemoveAutoConfigureTraces {} {
557 variable OptionControlledVariables
558 foreach varName [concat $OptionControlledVariables Option] {
560 foreach pair [trace vinfo $varName] {
561 foreach {op cmd} $pair break
562 if {[string equal r $op]
563 && [string match *ProcessCmdLineArgs* $cmd]} {
564 trace vdelete $varName $op $cmd
568 # Once the traces are removed, this can become a no-op
569 proc RemoveAutoConfigureTraces {} {}
572 proc Configure args {
575 set n [llength $args]
577 return [lsort [array names Option]]
580 if {[catch {MatchingOption [lindex $args 0]} option]} {
581 return -code error $option
583 return $Option($option)
585 while {[llength $args] > 1} {
586 if {[catch {MatchingOption [lindex $args 0]} option]} {
587 return -code error $option
589 if {[catch {$Verify($option) [lindex $args 1]} value]} {
590 return -code error "invalid $option\
591 value \"[lindex $args 1]\": $value"
593 set Option($option) $value
594 set args [lrange $args 2 end]
596 if {[llength $args]} {
597 if {[catch {MatchingOption [lindex $args 0]} option]} {
598 return -code error $option
600 return -code error "missing value for option $option"
603 proc configure args {
604 RemoveAutoConfigureTraces
605 set code [catch {Configure {*}$args} msg]
606 return -code $code $msg
609 proc AcceptVerbose { level } {
610 set level [AcceptList $level]
611 if {[llength $level] == 1} {
612 if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
613 # translate single characters abbreviations to expanded list
614 set level [string map {p pass b body s skip t start e error l line} \
620 if {[regexp {^(pass|body|skip|start|error|line)$} $v]} {
627 proc IsVerbose {level} {
629 return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
632 # Default verbosity is to show bodies of failed tests
633 Option -verbose {body error} {
634 Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
635 Test suite will display all passed tests if 'p' is specified, all
636 skipped tests if 's' is specified, the bodies of failed tests if
637 'b' is specified, and when tests start if 't' is specified.
638 ErrorInfo is displayed if 'e' is specified. Source file line
639 information of failed tests is displayed if 'l' is specified.
640 } AcceptVerbose verbose
642 # Match and skip patterns default to the empty list, except for
643 # matchFiles, which defaults to all .test files in the
644 # testsDirectory and matchDirectories, which defaults to all
647 Run all tests within the specified files that match one of the
648 list of glob patterns given.
652 Skip all tests within the specified tests (via -match) and files
653 that match one of the list of glob patterns given.
656 Option -file *.test {
657 Run tests in all test files that match the glob pattern given.
658 } AcceptPattern matchFiles
660 # By default, skip files that appear to be SCCS lock files.
661 Option -notfile l.*.test {
662 Skip all test files that match the glob pattern given.
663 } AcceptPattern skipFiles
665 Option -relateddir * {
666 Run tests in directories that match the glob pattern given.
667 } AcceptPattern matchDirectories
669 Option -asidefromdir {} {
670 Skip tests in directories that match the glob pattern given.
671 } AcceptPattern skipDirectories
673 # By default, don't save core files
674 Option -preservecore 0 {
675 If 2, save any core files produced during testing in the directory
676 specified by -tmpdir. If 1, notify the user if core files are
678 } AcceptInteger preserveCore
680 # debug output doesn't get printed by default; debug level 1 spits
681 # up only the tests that were skipped because they didn't match or
682 # were specifically skipped. A debug level of 2 would spit up the
683 # tcltest variables and flags provided; a debug level of 3 causes
684 # some additional output regarding operations of the test harness.
685 # The tcltest package currently implements only up to debug level 3.
688 } AcceptInteger debug
690 proc SetSelectedConstraints args {
692 foreach c $Option(-constraints) {
696 Option -constraints {} {
697 Do not skip the listed constraints listed in -constraints.
699 trace variable Option(-constraints) w \
700 [namespace code {SetSelectedConstraints ;#}]
702 # Don't run only the "-constraint" specified tests by default
703 proc ClearUnselectedConstraints args {
705 variable testConstraints
706 if {!$Option(-limitconstraints)} {return}
707 foreach c [array names testConstraints] {
708 if {[lsearch -exact $Option(-constraints) $c] == -1} {
713 Option -limitconstraints 0 {
714 whether to run only tests with the constraints
715 } AcceptBoolean limitConstraints
716 trace variable Option(-limitconstraints) w \
717 [namespace code {ClearUnselectedConstraints ;#}]
719 # A test application has to know how to load the tested commands
720 # into the interpreter.
722 Specifies the script to load the tested commands.
723 } AcceptScript loadScript
725 # Default is to run each test file in a separate process
726 Option -singleproc 0 {
727 whether to run all tests in one process
728 } AcceptBoolean singleProcess
730 proc AcceptTemporaryDirectory { directory } {
731 set directory [AcceptAbsolutePath $directory]
732 if {![file exists $directory]} {
733 file mkdir $directory
735 set directory [AcceptDirectory $directory]
736 if {![file writable $directory]} {
737 if {[string equal [workingDirectory] $directory]} {
738 # Special exception: accept the default value
739 # even if the directory is not writable
742 return -code error "\"$directory\" is not writeable"
747 # Directory where files should be created
748 Option -tmpdir [workingDirectory] {
749 Save temporary files in the specified directory.
750 } AcceptTemporaryDirectory temporaryDirectory
751 trace variable Option(-tmpdir) w \
752 [namespace code {normalizePath Option(-tmpdir) ;#}]
754 # Tests should not rely on the current working directory.
755 # Files that are part of the test suite should be accessed relative
756 # to [testsDirectory]
757 Option -testdir [workingDirectory] {
758 Search tests in the specified directory.
759 } AcceptDirectory testsDirectory
760 trace variable Option(-testdir) w \
761 [namespace code {normalizePath Option(-testdir) ;#}]
763 proc AcceptLoadFile { file } {
764 if {[string equal "" $file]} {return $file}
765 set file [file join [temporaryDirectory] $file]
766 return [AcceptReadable $file]
768 proc ReadLoadScript {args} {
770 if {[string equal "" $Option(-loadfile)]} {return}
771 set tmp [open $Option(-loadfile) r]
772 loadScript [read $tmp]
775 Option -loadfile {} {
776 Read the script to load the tested commands from the specified file.
777 } AcceptLoadFile loadFile
778 trace variable Option(-loadfile) w [namespace code ReadLoadScript]
780 proc AcceptOutFile { file } {
781 if {[string equal stderr $file]} {return $file}
782 if {[string equal stdout $file]} {return $file}
783 return [file join [temporaryDirectory] $file]
786 # output goes to stdout by default
787 Option -outfile stdout {
788 Send output from test runs to the specified file.
789 } AcceptOutFile outputFile
790 trace variable Option(-outfile) w \
791 [namespace code {outputChannel $Option(-outfile) ;#}]
793 # errors go to stderr by default
794 Option -errfile stderr {
795 Send errors from test runs to the specified file.
796 } AcceptOutFile errorFile
797 trace variable Option(-errfile) w \
798 [namespace code {errorChannel $Option(-errfile) ;#}]
800 proc loadIntoSlaveInterpreter {slave args} {
802 interp eval $slave [package ifneeded tcltest $Version]
803 interp eval $slave "tcltest::configure {*}{$args}"
804 interp alias $slave ::tcltest::ReportToMaster \
805 {} ::tcltest::ReportedFromSlave
807 proc ReportedFromSlave {total passed skipped failed because newfiles} {
809 variable skippedBecause
810 variable createdNewFiles
811 incr numTests(Total) $total
812 incr numTests(Passed) $passed
813 incr numTests(Skipped) $skipped
814 incr numTests(Failed) $failed
815 foreach {constraint count} $because {
816 incr skippedBecause($constraint) $count
818 foreach {testfile created} $newfiles {
819 lappend createdNewFiles($testfile) {*}$created
825 #####################################################################
829 # Internal helper procedures to write out debug information
830 # dependent on the chosen level. A test shell may overide
831 # them, f.e. to redirect the output into a different
832 # channel, or even into a GUI.
834 # tcltest::DebugPuts --
836 # Prints the specified string if the current debug level is
837 # higher than the provided level argument.
840 # level The lowest debug level triggering the output
841 # string The string to print out.
844 # Prints the string. Nothing else is allowed.
850 proc tcltest::DebugPuts {level string} {
852 if {$debug >= $level} {
858 # tcltest::DebugPArray --
860 # Prints the contents of the specified array if the current
861 # debug level is higher than the provided level argument
864 # level The lowest debug level triggering the output
865 # arrayvar The name of the array to print out.
868 # Prints the contents of the array. Nothing else is allowed.
874 proc tcltest::DebugPArray {level arrayvar} {
877 if {$debug >= $level} {
878 catch {upvar $arrayvar $arrayvar}
884 # Define our own [parray] in ::tcltest that will inherit use of the [puts]
885 # defined in ::tcltest. NOTE: Ought to construct with [info args] and
886 # [info default], but can't be bothered now. If [parray] changes, then
887 # this will need changing too.
889 proc tcltest::parray {a {pattern *}} [info body ::parray]
891 # tcltest::DebugDo --
893 # Executes the script if the current debug level is greater than
894 # the provided level argument
897 # level The lowest debug level triggering the execution.
898 # script The tcl script executed upon a debug level high enough.
901 # Arbitrary side effects, dependent on the executed script.
907 proc tcltest::DebugDo {level script} {
910 if {$debug >= $level} {
916 #####################################################################
918 proc tcltest::Warn {msg} {
919 puts [outputChannel] "WARNING: $msg"
922 # tcltest::mainThread
924 # Accessor command for tcltest variable mainThread.
926 proc tcltest::mainThread { {new ""} } {
928 if {[llength [info level 0]] == 1} {
934 # tcltest::testConstraint --
936 # sets a test constraint to a value; to do multiple constraints,
937 # call this proc multiple times. also returns the value of the
938 # named constraint if no value was supplied.
941 # constraint - name of the constraint
942 # value - new value for constraint (should be boolean) - if not
943 # supplied, this is a query
946 # content of tcltest::testConstraints($constraint)
951 proc tcltest::testConstraint {constraint {value ""}} {
952 variable testConstraints
954 DebugPuts 3 "entering testConstraint $constraint $value"
955 if {[llength [info level 0]] == 2} {
956 return $testConstraints($constraint)
958 # Check for boolean values
959 if {[catch {expr {$value && $value}} msg]} {
960 return -code error $msg
962 if {[limitConstraints]
963 && [lsearch -exact $Option(-constraints) $constraint] == -1} {
966 set testConstraints($constraint) $value
969 # tcltest::interpreter --
971 # the interpreter name stored in tcltest::tcltest
977 # content of tcltest::tcltest
982 proc tcltest::interpreter { {interp ""} } {
984 if {[llength [info level 0]] == 1} {
987 if {[string equal {} $interp]} {
994 #####################################################################
996 # tcltest::AddToSkippedBecause --
998 # Increments the variable used to track how many tests were
999 # skipped because of a particular constraint.
1002 # constraint The name of the constraint to be modified
1005 # Modifies tcltest::skippedBecause; sets the variable to 1 if
1006 # didn't previously exist - otherwise, it just increments it.
1011 proc tcltest::AddToSkippedBecause { constraint {value 1}} {
1012 # add the constraint to the list of constraints that kept tests
1014 variable skippedBecause
1016 if {[info exists skippedBecause($constraint)]} {
1017 incr skippedBecause($constraint) $value
1019 set skippedBecause($constraint) $value
1024 # tcltest::PrintError --
1026 # Prints errors to tcltest::errorChannel and then flushes that
1027 # channel, making sure that all messages are < 80 characters per
1031 # errorMsg String containing the error to be printed
1039 proc tcltest::PrintError {errorMsg} {
1040 set InitialMessage "Error: "
1041 set InitialMsgLen [string length $InitialMessage]
1042 puts -nonewline [errorChannel] $InitialMessage
1044 # Keep track of where the end of the string is.
1045 set endingIndex [string length $errorMsg]
1047 if {$endingIndex < (80 - $InitialMsgLen)} {
1048 puts [errorChannel] $errorMsg
1050 # Print up to 80 characters on the first line, including the
1052 set beginningIndex [string last " " [string range $errorMsg 0 \
1053 [expr {80 - $InitialMsgLen}]]]
1054 puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
1056 while {![string equal end $beginningIndex]} {
1057 puts -nonewline [errorChannel] \
1058 [string repeat " " $InitialMsgLen]
1059 if {($endingIndex - $beginningIndex)
1060 < (80 - $InitialMsgLen)} {
1061 puts [errorChannel] [string trim \
1062 [string range $errorMsg $beginningIndex end]]
1065 set newEndingIndex [expr {[string last " " \
1066 [string range $errorMsg $beginningIndex \
1067 [expr {$beginningIndex
1068 + (80 - $InitialMsgLen)}]
1069 ]] + $beginningIndex}]
1070 if {($newEndingIndex <= 0)
1071 || ($newEndingIndex <= $beginningIndex)} {
1072 set newEndingIndex end
1074 puts [errorChannel] [string trim \
1075 [string range $errorMsg \
1076 $beginningIndex $newEndingIndex]]
1077 set beginningIndex $newEndingIndex
1081 flush [errorChannel]
1085 # tcltest::SafeFetch --
1087 # The following trace procedure makes it so that we can safely
1088 # refer to non-existent members of the testConstraints array
1089 # without causing an error. Instead, reading a non-existent
1090 # member will return 0. This is necessary because tests are
1091 # allowed to use constraint "X" without ensuring that
1092 # testConstraints("X") is defined.
1095 # n1 - name of the array (testConstraints)
1096 # n2 - array key value (constraint name)
1097 # op - operation performed on testConstraints (generally r)
1103 # sets testConstraints($n2) to 0 if it's referenced but never
1106 proc tcltest::SafeFetch {n1 n2 op} {
1107 variable testConstraints
1108 DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
1109 if {[string equal {} $n2]} {return}
1110 if {![info exists testConstraints($n2)]} {
1111 if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
1112 testConstraint $n2 0
1117 # tcltest::ConstraintInitializer --
1119 # Get or set a script that when evaluated in the tcltest namespace
1120 # will return a boolean value with which to initialize the
1121 # associated constraint.
1124 # constraint - name of the constraint initialized by the script
1125 # script - the initializer script
1128 # boolean value of the constraint - enabled or disabled
1131 # Constraint is initialized for future reference by [test]
1132 proc tcltest::ConstraintInitializer {constraint {script ""}} {
1133 variable ConstraintInitializer
1134 DebugPuts 3 "entering ConstraintInitializer $constraint $script"
1135 if {[llength [info level 0]] == 2} {
1136 return $ConstraintInitializer($constraint)
1138 # Check for boolean values
1139 if {![info complete $script]} {
1140 return -code error "ConstraintInitializer must be complete script"
1142 set ConstraintInitializer($constraint) $script
1145 # tcltest::InitConstraints --
1147 # Call all registered constraint initializers to force initialization
1148 # of all known constraints.
1149 # See the tcltest man page for the list of built-in constraints defined
1150 # in this procedure.
1156 # The testConstraints array is reset to have an index for each
1157 # built-in test constraint.
1163 proc tcltest::InitConstraints {} {
1164 variable ConstraintInitializer
1166 foreach constraint [array names ConstraintInitializer] {
1167 testConstraint $constraint
1171 proc tcltest::DefineConstraintInitializers {} {
1172 ConstraintInitializer singleTestInterp {singleProcess}
1174 # All the 'pc' constraints are here for backward compatibility and
1175 # are not documented. They have been replaced with equivalent 'win'
1178 ConstraintInitializer unixOnly \
1179 {string equal $::tcl_platform(platform) unix}
1180 ConstraintInitializer macOnly \
1181 {string equal $::tcl_platform(platform) macintosh}
1182 ConstraintInitializer pcOnly \
1183 {string equal $::tcl_platform(platform) windows}
1184 ConstraintInitializer winOnly \
1185 {string equal $::tcl_platform(platform) windows}
1187 ConstraintInitializer unix {testConstraint unixOnly}
1188 ConstraintInitializer mac {testConstraint macOnly}
1189 ConstraintInitializer pc {testConstraint pcOnly}
1190 ConstraintInitializer win {testConstraint winOnly}
1192 ConstraintInitializer unixOrPc \
1193 {expr {[testConstraint unix] || [testConstraint pc]}}
1194 ConstraintInitializer macOrPc \
1195 {expr {[testConstraint mac] || [testConstraint pc]}}
1196 ConstraintInitializer unixOrWin \
1197 {expr {[testConstraint unix] || [testConstraint win]}}
1198 ConstraintInitializer macOrWin \
1199 {expr {[testConstraint mac] || [testConstraint win]}}
1200 ConstraintInitializer macOrUnix \
1201 {expr {[testConstraint mac] || [testConstraint unix]}}
1203 ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
1204 ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
1205 ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
1207 # The following Constraints switches are used to mark tests that
1208 # should work, but have been temporarily disabled on certain
1209 # platforms because they don't and we haven't gotten around to
1210 # fixing the underlying problem.
1212 ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
1213 ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
1214 ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
1215 ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
1217 # The following Constraints switches are used to mark tests that
1218 # crash on certain platforms, so that they can be reactivated again
1219 # when the underlying problem is fixed.
1221 ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
1222 ConstraintInitializer winCrash {expr {![testConstraint win]}}
1223 ConstraintInitializer macCrash {expr {![testConstraint mac]}}
1224 ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
1228 ConstraintInitializer emptyTest {format 0}
1230 # By default, tests that expose known bugs are skipped.
1232 ConstraintInitializer knownBug {format 0}
1234 # By default, non-portable tests are skipped.
1236 ConstraintInitializer nonPortable {format 0}
1238 # Some tests require user interaction.
1240 ConstraintInitializer userInteraction {format 0}
1242 # Some tests must be skipped if the interpreter is not in
1245 ConstraintInitializer interactive \
1246 {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
1248 # Some tests can only be run if the installation came from a CD
1249 # image instead of a web image. Some tests must be skipped if you
1250 # are running as root on Unix. Other tests can only be run if you
1251 # are running as root on Unix.
1253 ConstraintInitializer root {expr \
1254 {[string equal unix $::tcl_platform(platform)]
1255 && ([string equal root $::tcl_platform(user)]
1256 || [string equal "" $::tcl_platform(user)])}}
1257 ConstraintInitializer notRoot {expr {![testConstraint root]}}
1259 # Set nonBlockFiles constraint: 1 means this platform supports
1260 # setting files into nonblocking mode.
1262 ConstraintInitializer nonBlockFiles {
1263 set code [expr {[catch {set f [open defs r]}]
1264 || [catch {fconfigure $f -blocking off}]}]
1269 # Set asyncPipeClose constraint: 1 means this platform supports
1270 # async flush and async close on a pipe.
1272 # Test for SCO Unix - cannot run async flushing tests because a
1273 # potential problem with select is apparently interfering.
1276 ConstraintInitializer asyncPipeClose {expr {
1277 !([string equal unix $::tcl_platform(platform)]
1278 && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
1280 # Test to see if we have a broken version of sprintf with respect
1281 # to the "e" format of floating-point numbers.
1283 ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
1285 # Test to see if execed commands such as cat, echo, rm and so forth
1286 # are present on this machine.
1288 ConstraintInitializer unixExecs {
1290 if {[string equal macintosh $::tcl_platform(platform)]} {
1293 if {[string equal windows $::tcl_platform(platform)]} {
1295 set file _tcl_test_remove_me.txt
1296 makeFile {hello} $file
1300 [catch {exec cat $file}] ||
1301 [catch {exec echo hello}] ||
1302 [catch {exec sh -c echo hello}] ||
1303 [catch {exec wc $file}] ||
1304 [catch {exec sleep 1}] ||
1305 [catch {exec echo abc > $file}] ||
1306 [catch {exec chmod 644 $file}] ||
1307 [catch {exec rm $file}] ||
1308 [llength [auto_execok mkdir]] == 0 ||
1309 [llength [auto_execok fgrep]] == 0 ||
1310 [llength [auto_execok grep]] == 0 ||
1311 [llength [auto_execok ps]] == 0
1320 ConstraintInitializer stdio {
1322 if {![catch {set f [open "|[list [interpreter]]" w]}]} {
1323 if {![catch {puts $f exit}]} {
1324 if {![catch {close $f}]} {
1332 # Deliberately call socket with the wrong number of arguments. The
1333 # error message you get will indicate whether sockets are available
1336 ConstraintInitializer socket {
1338 string compare $msg "sockets are not available on this system"
1341 # Check for internationalization
1342 ConstraintInitializer hasIsoLocale {
1343 if {[llength [info commands testlocale]] == 0} {
1346 set code [string length [SetIso8859_1_Locale]]
1353 #####################################################################
1355 # Usage and command line arguments processing.
1357 # tcltest::PrintUsageInfo
1359 # Prints out the usage information for package tcltest. This can
1360 # be customized with the redefinition of [PrintUsageInfoHook].
1370 proc tcltest::PrintUsageInfo {} {
1375 proc tcltest::Usage { {option ""} } {
1378 if {[llength [info level 0]] == 1} {
1379 set msg "Usage: [file tail [info nameofexecutable]] script "
1380 append msg "?-help? ?flag value? ... \n"
1381 append msg "Available flags (and valid input values) are:"
1384 set allOpts [concat -help [Configure]]
1385 foreach opt $allOpts {
1386 set foo [Usage $opt]
1387 foreach [list x type($opt) usage($opt)] $foo break
1388 set line($opt) " $opt $type($opt) "
1389 set length($opt) [string length $line($opt)]
1390 if {$length($opt) > $max} {set max $length($opt)}
1392 set rest [expr {72 - $max}]
1393 foreach opt $allOpts {
1394 append msg \n$line($opt)
1395 append msg [string repeat " " [expr {$max - $length($opt)}]]
1396 set u [string trim $usage($opt)]
1397 catch {append u " (default: \[[Configure $opt]])"}
1398 regsub -all {\s*\n\s*} $u " " u
1399 while {[string length $u] > $rest} {
1400 set break [string wordstart $u $rest]
1402 set break [string wordend $u 0]
1404 append msg [string range $u 0 [expr {$break - 1}]]
1405 set u [string trim [string range $u $break end]]
1406 append msg \n[string repeat " " $max]
1411 } elseif {[string equal -help $option]} {
1412 return [list -help "" "Display this usage information."]
1414 set type [lindex [info args $Verify($option)] 0]
1415 return [list $option $type $Usage($option)]
1419 # tcltest::ProcessFlags --
1421 # process command line arguments supplied in the flagArray - this
1422 # is called by processCmdLineArgs. Modifies tcltest variables
1423 # according to the content of the flagArray.
1426 # flagArray - array containing name/value pairs of flags
1429 # sets tcltest variables according to their values as defined by
1435 proc tcltest::ProcessFlags {flagArray} {
1436 # Process -help first
1437 if {[lsearch -exact $flagArray {-help}] != -1} {
1442 if {[llength $flagArray] == 0} {
1443 RemoveAutoConfigureTraces
1446 while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
1448 # Something went wrong parsing $args for tcltest options
1449 # Check whether the problem is "unknown option"
1450 if {[regexp {^unknown option (\S+):} $msg -> option]} {
1451 # Could be this is an option the Hook knows about
1452 set moreOptions [processCmdLineArgsAddFlagsHook]
1453 if {[lsearch -exact $moreOptions $option] == -1} {
1454 # Nope. Report the error, including additional options,
1456 if {[llength $moreOptions]} {
1458 append msg [join [lrange $moreOptions 0 end-1] ", "]
1459 append msg "or [lindex $moreOptions end]"
1464 # error is something other than "unknown option"
1465 # notify user of the error; and exit
1466 puts [errorChannel] $msg
1470 # To recover, find that unknown option and remove up to it.
1472 while {![string equal [lindex $args 0] $option]} {
1473 set args [lrange $args 2 end]
1475 set args [lrange $args 2 end]
1477 if {[llength $args] == 1} {
1478 puts [errorChannel] \
1479 "missing value for option [lindex $args 0]"
1486 array set flag $flagArray
1487 processCmdLineArgsHook [array get flag]
1492 # tcltest::ProcessCmdLineArgs --
1494 # This procedure must be run after constraint initialization is
1495 # set up (by [DefineConstraintInitializers]) because some constraints
1496 # can be overridden.
1498 # Perform configuration according to the command-line options.
1504 # Sets the above-named variables in the tcltest namespace.
1510 proc tcltest::ProcessCmdLineArgs {} {
1511 variable originalEnv
1512 variable testConstraints
1514 # The "argv" var doesn't exist in some cases, so use {}.
1515 if {![info exists ::argv]} {
1518 ProcessFlags $::argv
1521 # Spit out everything you know if we're at a debug level 2 or
1523 DebugPuts 2 "Flags passed into tcltest:"
1524 if {[info exists ::env(TCLTEST_OPTIONS)]} {
1526 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
1528 if {[info exists ::argv]} {
1529 DebugPuts 2 " argv: $::argv"
1531 DebugPuts 2 "tcltest::debug = [debug]"
1532 DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
1533 DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
1534 DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
1535 DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
1536 DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
1537 DebugPuts 2 "Original environment (tcltest::originalEnv):"
1538 DebugPArray 2 originalEnv
1539 DebugPuts 2 "Constraints:"
1540 DebugPArray 2 testConstraints
1543 #####################################################################
1545 # Code to run the tests goes here.
1547 # tcltest::TestPuts --
1549 # Used to redefine puts in test environment. Stores whatever goes
1550 # out on stdout in tcltest::outData and stderr in errData before
1551 # sending it on to the regular puts.
1554 # same as standard puts
1560 # Intercepts puts; data that would otherwise go to stdout, stderr,
1561 # or file channels specified in outputChannel and errorChannel
1562 # does not get sent to the normal puts function.
1563 namespace eval tcltest::Replace {
1564 namespace export puts
1566 proc tcltest::Replace::puts {args} {
1567 variable [namespace parent]::outData
1568 variable [namespace parent]::errData
1569 switch [llength $args] {
1571 # Only the string to be printed is specified
1572 append outData [lindex $args 0]\n
1574 # return [Puts [lindex $args 0]]
1577 # Either -nonewline or channelId has been specified
1578 if {[string equal -nonewline [lindex $args 0]]} {
1579 append outData [lindex $args end]
1581 # return [Puts -nonewline [lindex $args end]]
1583 set channel [lindex $args 0]
1588 if {[string equal -nonewline [lindex $args 0]]} {
1589 # Both -nonewline and channelId are specified, unless
1590 # it's an error. -nonewline is supposed to be argv[0].
1591 set channel [lindex $args 1]
1597 if {[info exists channel]} {
1598 if {[string equal $channel [[namespace parent]::outputChannel]]
1599 || [string equal $channel stdout]} {
1600 append outData [lindex $args end]$newline
1602 } elseif {[string equal $channel [[namespace parent]::errorChannel]]
1603 || [string equal $channel stderr]} {
1604 append errData [lindex $args end]$newline
1609 # If we haven't returned by now, we don't know how to handle the
1610 # input. Let puts handle it.
1611 return [Puts {*}$args]
1616 # Evaluate the script in the test environment. If ignoreOutput is
1617 # false, store data sent to stderr and stdout in outData and
1618 # errData. Otherwise, ignore this output altogether.
1621 # script Script to evaluate
1622 # ?ignoreOutput? Indicates whether or not to ignore output
1623 # sent to stdout & stderr
1626 # result from running the script
1629 # Empties the contents of outData and errData before running a
1630 # test if ignoreOutput is set to 0.
1632 proc tcltest::Eval {script {ignoreOutput 1}} {
1635 DebugPuts 3 "[lindex [info level 0] 0] called"
1636 if {!$ignoreOutput} {
1639 rename ::puts [namespace current]::Replace::Puts
1640 namespace eval :: [list namespace import [namespace origin Replace::puts]]
1641 namespace import Replace::puts
1643 set result [uplevel 1 $script]
1644 if {!$ignoreOutput} {
1645 namespace forget puts
1646 namespace eval :: namespace forget puts
1647 rename [namespace current]::Replace::Puts ::puts
1652 # tcltest::CompareStrings --
1654 # compares the expected answer to the actual answer, depending on
1655 # the mode provided. Mode determines whether a regexp, exact,
1656 # glob or custom comparison is done.
1659 # actual - string containing the actual result
1660 # expected - pattern to be matched against
1661 # mode - type of comparison to be done
1664 # result of the match
1669 proc tcltest::CompareStrings {actual expected mode} {
1670 variable CustomMatch
1671 if {![info exists CustomMatch($mode)]} {
1672 return -code error "No matching command registered for `-match $mode'"
1674 set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
1675 if {[catch {expr {$match && $match}} result]} {
1676 return -code error "Invalid result from `-match $mode' command: $result"
1681 # tcltest::customMatch --
1683 # registers a command to be called when a particular type of
1684 # matching is required.
1687 # nickname - Keyword for the type of matching
1688 # cmd - Incomplete command that implements that type of matching
1689 # when completed with expected string and actual string
1690 # and then evaluated.
1696 # Sets the variable tcltest::CustomMatch
1698 proc tcltest::customMatch {mode script} {
1699 variable CustomMatch
1700 if {![info complete $script]} {
1701 return -code error \
1702 "invalid customMatch script; can't evaluate after completion"
1704 set CustomMatch($mode) $script
1707 # tcltest::SubstArguments list
1709 # This helper function takes in a list of words, then perform a
1710 # substitution on the list as though each word in the list is a separate
1711 # argument to the Tcl function. For example, if this function is
1714 # SubstArguments {$a {$a}}
1716 # Then it is as though the function is invoked as:
1718 # SubstArguments $a {$a}
1720 # This code is adapted from Paul Duffin's function "SplitIntoWords".
1721 # The original function can be found on:
1723 # http://purl.org/thecliff/tcl/wiki/858.html
1726 # a list containing the result of the substitution
1729 # An error may occur if the list containing unbalanced quote or
1736 proc tcltest::SubstArguments {argList} {
1738 # We need to split the argList up into tokens but cannot use list
1739 # operations as they throw away some significant quoting, and
1740 # [split] ignores braces as it should. Therefore what we do is
1741 # gradually build up a string out of whitespace seperated strings.
1742 # We cannot use [split] to split the argList into whitespace
1743 # separated strings as it throws away the whitespace which maybe
1744 # important so we have to do it all by hand.
1749 while {[string length $argList]} {
1750 # Look for the next word containing a quote: " { }
1751 if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
1753 # Get the text leading up to this word, but not including
1754 # this word, from the argList.
1755 set text [string range $argList 0 \
1756 [expr {[lindex $all 0] - 1}]]
1757 # Get the word with the quote
1758 set word [string range $argList \
1759 [lindex $all 0] [lindex $all 1]]
1761 # Remove all text up to and including the word from the
1763 set argList [string range $argList \
1764 [expr {[lindex $all 1] + 1}] end]
1766 # Take everything up to the end of the argList.
1773 # If we saw a word with quote before, then there is a
1774 # multi-word token starting with that word. In this case,
1775 # add the text and the current word to this token.
1776 append token $text $word
1778 # Add the text to the result. There is no need to parse
1779 # the text because it couldn't be a part of any multi-word
1780 # token. Then start a new multi-word token with the word
1781 # because we need to pass this token to the Tcl parser to
1782 # check for balancing quotes
1787 if { [catch {llength $token} length] == 0 && $length == 1} {
1788 # The token is a valid list so add it to the result.
1789 # lappend result [string trim $token]
1790 append result \{$token\}
1795 # If the last token has not been added to the list then there
1797 if { [string length $token] } {
1798 error "incomplete token \"$token\""
1807 # This procedure runs a test and prints an error message if the test
1808 # fails. If verbose has been set, it also prints a message even if the
1809 # test succeeds. The test will be skipped if it doesn't match the
1810 # match variable, if it matches an element in skip, or if one of the
1811 # elements of "constraints" turns out not to be true.
1813 # If testLevel is 1, then this is a top level test, and we record
1814 # pass/fail information; otherwise, this information is not logged and
1815 # is not added to running totals.
1818 # Only description is a required attribute. All others are optional.
1819 # Default values are indicated.
1821 # constraints - A list of one or more keywords, each of which
1822 # must be the name of an element in the array
1823 # "testConstraints". If any of these elements is
1824 # zero, the test is skipped. This attribute is
1825 # optional; default is {}
1826 # body - Script to run to carry out the test. It must
1827 # return a result that can be checked for
1828 # correctness. This attribute is optional;
1830 # result - Expected result from script. This attribute is
1831 # optional; default is {}.
1832 # output - Expected output sent to stdout. This attribute
1833 # is optional; default is {}.
1834 # errorOutput - Expected output sent to stderr. This attribute
1835 # is optional; default is {}.
1836 # returnCodes - Expected return codes. This attribute is
1837 # optional; default is {0 2}.
1838 # setup - Code to run before $script (above). This
1839 # attribute is optional; default is {}.
1840 # cleanup - Code to run after $script (above). This
1841 # attribute is optional; default is {}.
1842 # match - specifies type of matching to do on result,
1843 # output, errorOutput; this must be a string
1844 # previously registered by a call to [customMatch].
1845 # The strings exact, glob, and regexp are pre-registered
1846 # by the tcltest package. Default value is exact.
1849 # name - Name of test, in the form foo-1.2.
1850 # description - Short textual description of the test, to
1851 # help humans understand what it does.
1857 # Just about anything is possible depending on the test.
1860 proc tcltest::test {name description args} {
1863 variable coreModTime
1864 DebugPuts 3 "test $name $args"
1868 puts "test name '$name' re-used; prior use in $TestNames($name)"
1870 set TestNames($name) [info script]
1876 # Pre-define everything to null except output and errorOutput. We
1877 # determine whether or not to trap output based on whether or not
1878 # these variables (output & errorOutput) are defined.
1879 foreach item {constraints setup cleanup body result returnCodes
1884 # Set the default match mode
1887 # Set the default match values for return codes (0 is the standard
1888 # expected return value if everything went well; 2 represents
1889 # 'return' being used in the test script).
1890 set returnCodes [list 0 2]
1892 # The old test format can't have a 3rd argument (constraints or
1893 # script) that starts with '-'.
1894 if {[string match -* [lindex $args 0]]
1895 || ([llength $args] <= 1)} {
1896 if {[llength $args] == 1} {
1897 set list [SubstArguments [lindex $args 0]]
1898 foreach {element value} $list {
1899 set testAttributes($element) $value
1901 foreach item {constraints match setup body cleanup \
1902 result returnCodes output errorOutput} {
1903 if {[info exists testAttributes(-$item)]} {
1904 set testAttributes(-$item) [uplevel 1 \
1905 ::concat $testAttributes(-$item)]
1909 array set testAttributes $args
1912 set validFlags {-setup -cleanup -body -result -returnCodes \
1913 -match -output -errorOutput -constraints}
1915 foreach flag [array names testAttributes] {
1916 if {[lsearch -exact $validFlags $flag] == -1} {
1918 set sorted [lsort $validFlags]
1919 set options [join [lrange $sorted 0 end-1] ", "]
1920 append options ", or [lindex $sorted end]"
1921 return -code error "bad option \"$flag\": must be $options"
1925 # store whatever the user gave us
1926 foreach item [array names testAttributes] {
1927 set [string trimleft $item "-"] $testAttributes($item)
1930 # Check the values supplied for -match
1931 variable CustomMatch
1932 if {[lsearch [array names CustomMatch] $match] == -1} {
1934 set sorted [lsort [array names CustomMatch]]
1935 set values [join [lrange $sorted 0 end-1] ", "]
1936 append values ", or [lindex $sorted end]"
1937 return -code error "bad -match value \"$match\":\
1941 # Replace symbolic valies supplied for -returnCodes
1942 foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
1943 set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
1946 # This is parsing for the old test command format; it is here
1947 # for backward compatibility.
1948 set result [lindex $args end]
1949 if {[llength $args] == 2} {
1950 set body [lindex $args 0]
1951 } elseif {[llength $args] == 3} {
1952 set constraints [lindex $args 0]
1953 set body [lindex $args 1]
1956 return -code error "wrong # args:\
1957 should be \"test name desc ?options?\""
1961 if {[Skipped $name $constraints]} {
1966 # Save information about the core file.
1967 if {[preserveCore]} {
1968 if {[file exists [file join [workingDirectory] core]]} {
1969 set coreModTime [file mtime [file join [workingDirectory] core]]
1973 # First, run the setup script
1974 set code [catch {uplevel 1 $setup} setupMsg]
1976 set errorInfo(setup) $::errorInfo
1977 set errorCode(setup) $::errorCode
1979 set setupFailure [expr {$code != 0}]
1981 # Only run the test body if the setup was successful
1982 if {!$setupFailure} {
1984 # Verbose notification of $body start
1985 if {[IsVerbose start]} {
1986 puts [outputChannel] "---- $name start"
1987 flush [outputChannel]
1990 set command [list [namespace origin RunTest] $name $body]
1991 if {[info exists output] || [info exists errorOutput]} {
1992 set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
1994 set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
1996 foreach {actualAnswer returnCode} $testResult break
1997 if {$returnCode == 1} {
1998 set errorInfo(body) $::errorInfo
1999 set errorCode(body) $::errorCode
2003 # Always run the cleanup script
2004 set code [catch {uplevel 1 $cleanup} cleanupMsg]
2006 set errorInfo(cleanup) $::errorInfo
2007 set errorCode(cleanup) $::errorCode
2009 set cleanupFailure [expr {$code != 0}]
2013 # check for a core file first - if one was created by the test,
2014 # then the test failed
2015 if {[preserveCore]} {
2016 if {[file exists [file join [workingDirectory] core]]} {
2017 # There's only a test failure if there is a core file
2018 # and (1) there previously wasn't one or (2) the new
2019 # one is different from the old one.
2020 if {[info exists coreModTime]} {
2021 if {$coreModTime != [file mtime \
2022 [file join [workingDirectory] core]]} {
2029 if {([preserveCore] > 1) && ($coreFailure)} {
2030 append coreMsg "\nMoving file to:\
2031 [file join [temporaryDirectory] core-$name]"
2032 catch {file rename -force \
2033 [file join [workingDirectory] core] \
2034 [file join [temporaryDirectory] core-$name]
2036 if {[string length $msg] > 0} {
2037 append coreMsg "\nError:\
2038 Problem renaming core file: $msg"
2044 # check if the return code matched the expected return code
2046 if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
2050 # If expected output/error strings exist, we have to compare
2051 # them. If the comparison fails, then so did the test.
2054 if {[info exists output] && !$codeFailure} {
2055 if {[set outputCompare [catch {
2056 CompareStrings $outData $output $match
2057 } outputMatch]] == 0} {
2058 set outputFailure [expr {!$outputMatch}]
2066 if {[info exists errorOutput] && !$codeFailure} {
2067 if {[set errorCompare [catch {
2068 CompareStrings $errData $errorOutput $match
2069 } errorMatch]] == 0} {
2070 set errorFailure [expr {!$errorMatch}]
2076 # check if the answer matched the expected answer
2077 # Only check if we ran the body of the test (no setup failure)
2078 if {$setupFailure || $codeFailure} {
2080 } elseif {[set scriptCompare [catch {
2081 CompareStrings $actualAnswer $result $match
2082 } scriptMatch]] == 0} {
2083 set scriptFailure [expr {!$scriptMatch}]
2088 # if we didn't experience any failures, then we passed
2090 if {!($setupFailure || $cleanupFailure || $coreFailure
2091 || $outputFailure || $errorFailure || $codeFailure
2092 || $scriptFailure)} {
2093 if {$testLevel == 1} {
2094 incr numTests(Passed)
2095 if {[IsVerbose pass]} {
2096 puts [outputChannel] "++++ $name PASSED"
2103 # We know the test failed, tally it...
2104 if {$testLevel == 1} {
2105 incr numTests(Failed)
2108 # ... then report according to the type of failure
2109 variable currentFailure true
2110 if {![IsVerbose body]} {
2113 puts [outputChannel] "\n"
2114 if {[IsVerbose line]} {
2115 if {![catch {set testFrame [info frame -1]}] &&
2116 [dict get $testFrame type] eq "source"} {
2117 set testFile [dict get $testFrame file]
2118 set testLine [dict get $testFrame line]
2120 set testFile [file normalize [uplevel 1 {info script}]]
2121 if {[file readable $testFile]} {
2122 set testFd [open $testFile r]
2123 set testLine [expr {[lsearch -regexp \
2124 [split [read $testFd] "\n"] \
2125 "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
2129 if {[info exists testLine]} {
2130 puts [outputChannel] "$testFile:$testLine: error: test failed:\
2131 $name [string trim $description]"
2134 puts [outputChannel] "==== $name\
2135 [string trim $description] FAILED"
2136 if {[string length $body]} {
2137 puts [outputChannel] "==== Contents of test case:"
2138 puts [outputChannel] $body
2140 if {$setupFailure} {
2141 puts [outputChannel] "---- Test setup\
2143 if {[info exists errorInfo(setup)]} {
2144 puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
2145 puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
2148 if {$scriptFailure} {
2149 if {$scriptCompare} {
2150 puts [outputChannel] "---- Error testing result: $scriptMatch"
2152 puts [outputChannel] "---- Result was:\n$actualAnswer"
2153 puts [outputChannel] "---- Result should have been\
2154 ($match matching):\n$result"
2158 switch -- $returnCode {
2159 0 { set msg "Test completed normally" }
2160 1 { set msg "Test generated error" }
2161 2 { set msg "Test generated return exception" }
2162 3 { set msg "Test generated break exception" }
2163 4 { set msg "Test generated continue exception" }
2164 default { set msg "Test generated exception" }
2166 puts [outputChannel] "---- $msg; Return code was: $returnCode"
2167 puts [outputChannel] "---- Return code should have been\
2168 one of: $returnCodes"
2169 if {[IsVerbose error]} {
2170 if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
2171 puts [outputChannel] "---- errorInfo: $errorInfo(body)"
2172 puts [outputChannel] "---- errorCode: $errorCode(body)"
2176 if {$outputFailure} {
2177 if {$outputCompare} {
2178 puts [outputChannel] "---- Error testing output: $outputMatch"
2180 puts [outputChannel] "---- Output was:\n$outData"
2181 puts [outputChannel] "---- Output should have been\
2182 ($match matching):\n$output"
2185 if {$errorFailure} {
2186 if {$errorCompare} {
2187 puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
2189 puts [outputChannel] "---- Error output was:\n$errData"
2190 puts [outputChannel] "---- Error output should have\
2191 been ($match matching):\n$errorOutput"
2194 if {$cleanupFailure} {
2195 puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
2196 if {[info exists errorInfo(cleanup)]} {
2197 puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
2198 puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
2202 puts [outputChannel] "---- Core file produced while running\
2205 puts [outputChannel] "==== $name FAILED\n"
2213 # Given a test name and it constraints, returns a boolean indicating
2214 # whether the current configuration says the test should be skipped.
2216 # Side Effects: Maintains tally of total tests seen and tests skipped.
2218 proc tcltest::Skipped {name constraints} {
2221 variable testConstraints
2223 if {$testLevel == 1} {
2224 incr numTests(Total)
2226 # skip the test if it's name matches an element of skip
2227 foreach pattern [skip] {
2228 if {[string match $pattern $name]} {
2229 if {$testLevel == 1} {
2230 incr numTests(Skipped)
2231 DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
2236 # skip the test if it's name doesn't match any element of match
2238 foreach pattern [match] {
2239 if {[string match $pattern $name]} {
2245 if {$testLevel == 1} {
2246 incr numTests(Skipped)
2247 DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
2251 if {[string equal {} $constraints]} {
2252 # If we're limited to the listed constraints and there aren't
2253 # any listed, then we shouldn't run the test.
2254 if {[limitConstraints]} {
2255 AddToSkippedBecause userSpecifiedLimitConstraint
2256 if {$testLevel == 1} {
2257 incr numTests(Skipped)
2262 # "constraints" argument exists;
2263 # make sure that the constraints are satisfied.
2266 if {[string match {*[$\[]*} $constraints] != 0} {
2267 # full expression, e.g. {$foo > [info tclversion]}
2268 catch {set doTest [uplevel #0 [list expr $constraints]]}
2269 } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
2270 # something like {a || b} should be turned into
2271 # $testConstraints(a) || $testConstraints(b).
2272 regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
2273 catch {set doTest [eval [list expr $c]]}
2274 } elseif {![catch {llength $constraints}]} {
2275 # just simple constraints such as {unixOnly fonts}.
2277 foreach constraint $constraints {
2278 if {(![info exists testConstraints($constraint)]) \
2279 || (!$testConstraints($constraint))} {
2282 # store the constraint that kept the test from
2284 set constraints $constraint
2291 if {[IsVerbose skip]} {
2292 puts [outputChannel] "++++ $name SKIPPED: $constraints"
2295 if {$testLevel == 1} {
2296 incr numTests(Skipped)
2297 AddToSkippedBecause $constraints
2307 # This is where the body of a test is evaluated. The combination of
2308 # [RunTest] and [Eval] allows the output and error output of the test
2309 # body to be captured for comparison against the expected values.
2311 proc tcltest::RunTest {name script} {
2312 DebugPuts 3 "Running $name {$script}"
2314 # If there is no "memory" command (because memory debugging isn't
2315 # enabled), then don't attempt to use the command.
2317 if {[llength [info commands memory]] == 1} {
2321 set code [catch {uplevel 1 $script} actualAnswer]
2323 return [list $actualAnswer $code]
2326 #####################################################################
2328 # tcltest::cleanupTestsHook --
2330 # This hook allows a harness that builds upon tcltest to specify
2331 # additional things that should be done at cleanup.
2334 if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
2335 proc tcltest::cleanupTestsHook {} {}
2338 # tcltest::cleanupTests --
2340 # Remove files and dirs created using the makeFile and makeDirectory
2341 # commands since the last time this proc was invoked.
2343 # Print the names of the files created without the makeFile command
2344 # since the tests were invoked.
2346 # Print the number tests (total, passed, failed, and skipped) since the
2347 # tests were invoked.
2349 # Restore original environment (as reported by special variable env).
2352 # calledFromAllFile - if 0, behave as if we are running a single
2353 # test file within an entire suite of tests. if we aren't running
2354 # a single test file, then don't report status. check for new
2355 # files created during the test run and report on them. if 1,
2356 # report collated status from all the test file runs.
2365 proc tcltest::cleanupTests {{calledFromAllFile 0}} {
2367 variable filesExisted
2368 variable createdNewFiles
2369 variable testSingleFile
2371 variable numTestFiles
2373 variable skippedBecause
2374 variable currentFailure
2375 variable originalEnv
2376 variable originalTclPlatform
2377 variable coreModTime
2380 set testFileName [file tail [info script]]
2382 # Hook to handle reporting to a parent interpreter
2383 if {[llength [info commands [namespace current]::ReportToMaster]]} {
2384 ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
2385 $numTests(Failed) [array get skippedBecause] \
2386 [array get createdNewFiles]
2387 set testSingleFile false
2390 # Call the cleanup hook
2393 # Remove files and directories created by the makeFile and
2394 # makeDirectory procedures. Record the names of files in
2395 # workingDirectory that were not pre-existing, and associate them
2396 # with the test file that created them.
2398 if {!$calledFromAllFile} {
2399 foreach file $filesMade {
2400 if {[file exists $file]} {
2401 DebugDo 1 {Warn "cleanupTests deleting $file..."}
2402 catch {file delete -force $file}
2406 foreach file [glob -nocomplain \
2407 -directory [temporaryDirectory] *] {
2408 lappend currentFiles [file tail $file]
2411 foreach file $currentFiles {
2412 if {[lsearch -exact $filesExisted $file] == -1} {
2413 lappend newFiles $file
2416 set filesExisted $currentFiles
2417 if {[llength $newFiles] > 0} {
2418 set createdNewFiles($testFileName) $newFiles
2422 if {$calledFromAllFile || $testSingleFile} {
2426 puts -nonewline [outputChannel] "$testFileName:"
2427 foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2428 puts -nonewline [outputChannel] \
2429 "\t$index\t$numTests($index)"
2431 puts [outputChannel] ""
2433 # print number test files sourced
2434 # print names of files that ran tests which failed
2436 if {$calledFromAllFile} {
2437 puts [outputChannel] \
2438 "Sourced $numTestFiles Test Files."
2440 if {[llength $failFiles] > 0} {
2441 puts [outputChannel] \
2442 "Files with failing tests: $failFiles"
2447 # if any tests were skipped, print the constraints that kept
2448 # them from running.
2450 set constraintList [array names skippedBecause]
2451 if {[llength $constraintList] > 0} {
2452 puts [outputChannel] \
2453 "Number of tests skipped for each constraint:"
2454 foreach constraint [lsort $constraintList] {
2455 puts [outputChannel] \
2456 "\t$skippedBecause($constraint)\t$constraint"
2457 unset skippedBecause($constraint)
2461 # report the names of test files in createdNewFiles, and reset
2462 # the array to be empty.
2464 set testFilesThatTurded [lsort [array names createdNewFiles]]
2465 if {[llength $testFilesThatTurded] > 0} {
2466 puts [outputChannel] "Warning: files left behind:"
2467 foreach testFile $testFilesThatTurded {
2468 puts [outputChannel] \
2469 "\t$testFile:\t$createdNewFiles($testFile)"
2470 unset createdNewFiles($testFile)
2474 # reset filesMade, filesExisted, and numTests
2477 foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2478 set numTests($index) 0
2481 # exit only if running Tk in non-interactive mode
2482 # This should be changed to determine if an event
2483 # loop is running, which is the real issue.
2484 # Actually, this doesn't belong here at all. A package
2485 # really has no business [exit]-ing an application.
2486 if {![catch {package present Tk}] && ![testConstraint interactive]} {
2491 # if we're deferring stat-reporting until all files are sourced,
2492 # then add current file to failFile list if any tests in this
2495 if {$currentFailure \
2496 && ([lsearch -exact $failFiles $testFileName] == -1)} {
2497 lappend failFiles $testFileName
2499 set currentFailure false
2501 # restore the environment to the state it was in before this package
2507 foreach index [array names ::env] {
2508 if {![info exists originalEnv($index)]} {
2509 lappend newEnv $index
2512 if {$::env($index) != $originalEnv($index)} {
2513 lappend changedEnv $index
2514 set ::env($index) $originalEnv($index)
2518 foreach index [array names originalEnv] {
2519 if {![info exists ::env($index)]} {
2520 lappend removedEnv $index
2521 set ::env($index) $originalEnv($index)
2524 if {[llength $newEnv] > 0} {
2525 puts [outputChannel] \
2526 "env array elements created:\t$newEnv"
2528 if {[llength $changedEnv] > 0} {
2529 puts [outputChannel] \
2530 "env array elements changed:\t$changedEnv"
2532 if {[llength $removedEnv] > 0} {
2533 puts [outputChannel] \
2534 "env array elements removed:\t$removedEnv"
2537 set changedTclPlatform {}
2538 foreach index [array names originalTclPlatform] {
2539 if {$::tcl_platform($index) \
2540 != $originalTclPlatform($index)} {
2541 lappend changedTclPlatform $index
2542 set ::tcl_platform($index) $originalTclPlatform($index)
2545 if {[llength $changedTclPlatform] > 0} {
2546 puts [outputChannel] "tcl_platform array elements\
2547 changed:\t$changedTclPlatform"
2550 if {[file exists [file join [workingDirectory] core]]} {
2551 if {[preserveCore] > 1} {
2552 puts "rename core file (> 1)"
2553 puts [outputChannel] "produced core file! \
2555 [file join [temporaryDirectory] core-$testFileName]"
2556 catch {file rename -force \
2557 [file join [workingDirectory] core] \
2558 [file join [temporaryDirectory] core-$testFileName]
2560 if {[string length $msg] > 0} {
2561 PrintError "Problem renaming file: $msg"
2564 # Print a message if there is a core file and (1) there
2565 # previously wasn't one or (2) the new one is different
2568 if {[info exists coreModTime]} {
2569 if {$coreModTime != [file mtime \
2570 [file join [workingDirectory] core]]} {
2571 puts [outputChannel] "A core file was created!"
2574 puts [outputChannel] "A core file was created!"
2579 flush [outputChannel]
2580 flush [errorChannel]
2584 #####################################################################
2586 # Procs that determine which tests/test files to run
2588 # tcltest::GetMatchingFiles
2590 # Looks at the patterns given to match and skip files and uses
2591 # them to put together a list of the tests that will be run.
2594 # directory to search
2597 # The constructed list is returned to the user. This will
2598 # primarily be used in 'all.tcl' files. It is used in
2604 # a lower case version is needed for compatibility with tcltest 1.0
2605 proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
2607 proc tcltest::GetMatchingFiles { args } {
2608 if {[llength $args]} {
2611 # Finding tests only in [testsDirectory] is normal operation.
2612 # This procedure is written to accept multiple directory arguments
2613 # only to satisfy version 1 compatibility.
2614 set dirList [list [testsDirectory]]
2617 set matchingFiles [list]
2618 foreach directory $dirList {
2620 # List files in $directory that match patterns to run.
2621 set matchFileList [list]
2622 foreach match [matchFiles] {
2623 set matchFileList [concat $matchFileList \
2624 [glob -directory $directory -types {b c f p s} \
2625 -nocomplain -- $match]]
2628 # List files in $directory that match patterns to skip.
2629 set skipFileList [list]
2630 foreach skip [skipFiles] {
2631 set skipFileList [concat $skipFileList \
2632 [glob -directory $directory -types {b c f p s} \
2633 -nocomplain -- $skip]]
2636 # Add to result list all files in match list and not in skip list
2637 foreach file $matchFileList {
2638 if {[lsearch -exact $skipFileList $file] == -1} {
2639 lappend matchingFiles $file
2644 if {[llength $matchingFiles] == 0} {
2645 PrintError "No test files remain after applying your match and\
2648 return $matchingFiles
2651 # tcltest::GetMatchingDirectories --
2653 # Looks at the patterns given to match and skip directories and
2654 # uses them to put together a list of the test directories that we
2655 # should attempt to run. (Only subdirectories containing an
2656 # "all.tcl" file are put into the list.)
2659 # root directory from which to search
2662 # The constructed list is returned to the user. This is used in
2663 # the primary all.tcl file.
2668 proc tcltest::GetMatchingDirectories {rootdir} {
2670 # Determine the skip list first, to avoid [glob]-ing over subdirectories
2671 # we're going to throw away anyway. Be sure we skip the $rootdir if it
2672 # comes up to avoid infinite loops.
2673 set skipDirs [list $rootdir]
2674 foreach pattern [skipDirectories] {
2675 set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
2676 -nocomplain -- $pattern]]
2679 # Now step through the matching directories, prune out the skipped ones
2681 set matchDirs [list]
2682 foreach pattern [matchDirectories] {
2683 foreach path [glob -directory $rootdir -types d -nocomplain -- \
2685 if {[lsearch -exact $skipDirs $path] == -1} {
2686 set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
2687 if {[file exists [file join $path all.tcl]]} {
2688 lappend matchDirs $path
2694 if {[llength $matchDirs] == 0} {
2695 DebugPuts 1 "No test directories remain after applying match\
2701 # tcltest::runAllTests --
2703 # prints output and sources test files according to the match and
2704 # skip patterns provided. after sourcing test files, it goes on
2705 # to source all.tcl files in matching test subdirectories.
2708 # shell being tested
2716 proc tcltest::runAllTests { {shell ""} } {
2717 variable testSingleFile
2718 variable numTestFiles
2721 variable DefaultValue
2724 if {[llength [info level 0]] == 1} {
2725 set shell [interpreter]
2728 set testSingleFile false
2730 puts [outputChannel] "Tests running in interp: $shell"
2731 puts [outputChannel] "Tests located in: [testsDirectory]"
2732 puts [outputChannel] "Tests running in: [workingDirectory]"
2733 puts [outputChannel] "Temporary files stored in\
2734 [temporaryDirectory]"
2736 # [file system] first available in Tcl 8.4
2737 if {![catch {file system [testsDirectory]} result]
2738 && ![string equal native [lindex $result 0]]} {
2739 # If we aren't running in the native filesystem, then we must
2740 # run the tests in a single process (via 'source'), because
2741 # trying to run then via a pipe will fail since the files don't
2746 if {[singleProcess]} {
2747 puts [outputChannel] \
2748 "Test files sourced into current interpreter"
2750 puts [outputChannel] \
2751 "Test files run in separate interpreters"
2753 if {[llength [skip]] > 0} {
2754 puts [outputChannel] "Skipping tests that match: [skip]"
2756 puts [outputChannel] "Running tests that match: [match]"
2758 if {[llength [skipFiles]] > 0} {
2759 puts [outputChannel] \
2760 "Skipping test files that match: [skipFiles]"
2762 if {[llength [matchFiles]] > 0} {
2763 puts [outputChannel] \
2764 "Only running test files that match: [matchFiles]"
2767 set timeCmd {clock format [clock seconds]}
2768 puts [outputChannel] "Tests began at [eval $timeCmd]"
2770 # Run each of the specified tests
2771 foreach file [lsort [GetMatchingFiles]] {
2772 set tail [file tail $file]
2773 puts [outputChannel] $tail
2774 flush [outputChannel]
2776 if {[singleProcess]} {
2778 uplevel 1 [list ::source $file]
2780 # Pass along our configuration to the child processes.
2781 # EXCEPT for the -outfile, because the parent process
2782 # needs to read and process output of children.
2783 set childargv [list]
2784 foreach opt [Configure] {
2785 if {[string equal $opt -outfile]} {continue}
2786 set value [Configure $opt]
2787 # Don't bother passing default configuration options
2788 if {[string equal $value $DefaultValue($opt)]} {
2791 lappend childargv $opt $value
2793 set cmd [linsert $childargv 0 | $shell $file]
2796 set pipeFd [open $cmd "r"]
2797 while {[gets $pipeFd line] >= 0} {
2801 {Passed\t([0-9]+)\t}
2802 {Skipped\t([0-9]+)\t}
2804 } ""] $line null testFile \
2805 Total Passed Skipped Failed]} {
2806 foreach index {Total Passed Skipped Failed} {
2807 incr numTests($index) [set $index]
2810 lappend failFiles $testFile
2812 } elseif {[regexp [join {
2813 {^Number of tests skipped }
2814 {for each constraint:}
2816 } ""] $line match skipped constraint]} {
2817 if {[string match \t* $match]} {
2818 AddToSkippedBecause $constraint $skipped
2821 puts [outputChannel] $line
2826 puts [outputChannel] "Test file error: $msg"
2827 # append the name of the test to a list to be reported
2829 lappend testFileFailures $file
2835 puts [outputChannel] "\nTests ended at [eval $timeCmd]"
2837 if {[info exists testFileFailures]} {
2838 puts [outputChannel] "\nTest files exiting with errors: \n"
2839 foreach file $testFileFailures {
2840 puts [outputChannel] " [file tail $file]\n"
2844 # Checking for subdirectories in which to run tests
2845 foreach directory [GetMatchingDirectories [testsDirectory]] {
2846 set dir [file tail $directory]
2847 puts [outputChannel] [string repeat ~ 44]
2848 puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
2850 uplevel 1 [list ::source [file join $directory all.tcl]]
2852 set endTime [eval $timeCmd]
2853 puts [outputChannel] "\n$dir test ended at $endTime"
2854 puts [outputChannel] ""
2855 puts [outputChannel] [string repeat ~ 44]
2860 #####################################################################
2862 # Test utility procs - not used in tcltest, but may be useful for
2865 # tcltest::loadTestedCommands --
2867 # Uses the specified script to load the commands to test. Allowed to
2868 # be empty, as the tested commands could have been compiled into the
2880 proc tcltest::loadTestedCommands {} {
2882 if {[string equal {} [loadScript]]} {
2886 return [uplevel 1 [loadScript]]
2889 # tcltest::saveState --
2891 # Save information regarding what procs and variables exist.
2897 # Modifies the variable saveState
2902 proc tcltest::saveState {} {
2904 uplevel 1 [list ::set [namespace which -variable saveState]] \
2905 {[::list [::info procs] [::info vars]]}
2906 DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
2910 # tcltest::restoreState --
2912 # Remove procs and variables that didn't exist before the call to
2919 # Removes procs and variables from your environment if they don't
2920 # exist in the saveState variable.
2925 proc tcltest::restoreState {} {
2927 foreach p [uplevel 1 {::info procs}] {
2928 if {([lsearch [lindex $saveState 0] $p] < 0)
2929 && ![string equal [namespace current]::$p \
2930 [uplevel 1 [list ::namespace origin $p]]]} {
2932 DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
2933 uplevel 1 [list ::catch [list ::rename $p {}]]
2936 foreach p [uplevel 1 {::info vars}] {
2937 if {[lsearch [lindex $saveState 1] $p] < 0} {
2938 DebugPuts 2 "[lindex [info level 0] 0]:\
2939 Removing variable $p"
2940 uplevel 1 [list ::catch [list ::unset $p]]
2946 # tcltest::normalizeMsg --
2948 # Removes "extra" newlines from a string.
2951 # msg String to be modified
2954 # string with extra newlines removed
2959 proc tcltest::normalizeMsg {msg} {
2960 regsub "\n$" [string tolower $msg] "" msg
2961 set msg [string map [list "\n\n" "\n"] $msg]
2962 return [string map [list "\n\}" "\}"] $msg]
2965 # tcltest::makeFile --
2967 # Create a new file with the name <name>, and write <contents> to it.
2969 # If this file hasn't been created via makeFile since the last time
2970 # cleanupTests was called, add it to the $filesMade list, so it will be
2971 # removed by the next call to cleanupTests.
2974 # contents content of the new file
2975 # name name of the new file
2976 # directory directory name for new file
2979 # absolute path to the file created
2984 proc tcltest::makeFile {contents name {directory ""}} {
2988 if {[llength [info level 0]] == 3} {
2989 set directory [temporaryDirectory]
2992 set fullName [file join $directory $name]
2994 DebugPuts 3 "[lindex [info level 0] 0]:\
2995 putting ``$contents'' into $fullName"
2997 set fd [open $fullName w]
2998 fconfigure $fd -translation lf
2999 if {[string equal [string index $contents end] \n]} {
3000 puts -nonewline $fd $contents
3006 if {[lsearch -exact $filesMade $fullName] == -1} {
3007 lappend filesMade $fullName
3012 # tcltest::removeFile --
3014 # Removes the named file from the filesystem
3017 # name file to be removed
3018 # directory directory from which to remove file
3021 # return value from [file delete]
3026 proc tcltest::removeFile {name {directory ""}} {
3029 if {[llength [info level 0]] == 2} {
3030 set directory [temporaryDirectory]
3032 set fullName [file join $directory $name]
3033 DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
3034 set idx [lsearch -exact $filesMade $fullName]
3035 set filesMade [lreplace $filesMade $idx $idx]
3038 Warn "removeFile removing \"$fullName\":\n not created by makeFile"
3041 if {![file isfile $fullName]} {
3043 Warn "removeFile removing \"$fullName\":\n not a file"
3046 return [file delete $fullName]
3049 # tcltest::makeDirectory --
3051 # Create a new dir with the name <name>.
3053 # If this dir hasn't been created via makeDirectory since the last time
3054 # cleanupTests was called, add it to the $directoriesMade list, so it
3055 # will be removed by the next call to cleanupTests.
3058 # name name of the new directory
3059 # directory directory in which to create new dir
3062 # absolute path to the directory created
3067 proc tcltest::makeDirectory {name {directory ""}} {
3070 if {[llength [info level 0]] == 2} {
3071 set directory [temporaryDirectory]
3073 set fullName [file join $directory $name]
3074 DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
3075 file mkdir $fullName
3076 if {[lsearch -exact $filesMade $fullName] == -1} {
3077 lappend filesMade $fullName
3082 # tcltest::removeDirectory --
3084 # Removes a named directory from the file system.
3087 # name Name of the directory to remove
3088 # directory Directory from which to remove
3091 # return value from [file delete]
3096 proc tcltest::removeDirectory {name {directory ""}} {
3099 if {[llength [info level 0]] == 2} {
3100 set directory [temporaryDirectory]
3102 set fullName [file join $directory $name]
3103 DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
3104 set idx [lsearch -exact $filesMade $fullName]
3105 set filesMade [lreplace $filesMade $idx $idx]
3108 Warn "removeDirectory removing \"$fullName\":\n not created\
3112 if {![file isdirectory $fullName]} {
3114 Warn "removeDirectory removing \"$fullName\":\n not a directory"
3117 return [file delete -force $fullName]
3120 # tcltest::viewFile --
3122 # reads the content of a file and returns it
3125 # name of the file to read
3126 # directory in which file is located
3129 # content of the named file
3134 proc tcltest::viewFile {name {directory ""}} {
3136 if {[llength [info level 0]] == 2} {
3137 set directory [temporaryDirectory]
3139 set fullName [file join $directory $name]
3140 set f [open $fullName]
3141 set data [read -nonewline $f]
3146 # tcltest::bytestring --
3148 # Construct a string that consists of the requested sequence of bytes,
3149 # as opposed to a string of properly formed UTF-8 characters.
3150 # This allows the tester to
3151 # 1. Create denormalized or improperly formed strings to pass to C
3152 # procedures that are supposed to accept strings with embedded NULL
3154 # 2. Confirm that a string result has a certain pattern of bytes, for
3155 # instance to confirm that "\xe0\0" in a Tcl script is stored
3156 # internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
3158 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
3159 # construct improperly formed strings in this manner, because it involves
3160 # exposing that Tcl uses UTF-8 internally.
3163 # string being converted
3166 # result fom encoding
3171 proc tcltest::bytestring {string} {
3172 return [encoding convertfrom identity $string]
3175 # tcltest::OpenFiles --
3177 # used in io tests, uses testchannel
3188 proc tcltest::OpenFiles {} {
3189 if {[catch {testchannel open} result]} {
3195 # tcltest::LeakFiles --
3197 # used in io tests, uses testchannel
3208 proc tcltest::LeakFiles {old} {
3209 if {[catch {testchannel open} new]} {
3214 if {[lsearch $old $p] < 0} {
3222 # Internationalization / ISO support procs -- dl
3225 # tcltest::SetIso8859_1_Locale --
3227 # used in cmdIL.test, uses testlocale
3238 proc tcltest::SetIso8859_1_Locale {} {
3239 variable previousLocale
3241 if {[info commands testlocale] != ""} {
3242 set previousLocale [testlocale ctype]
3243 testlocale ctype $isoLocale
3248 # tcltest::RestoreLocale --
3250 # used in cmdIL.test, uses testlocale
3261 proc tcltest::RestoreLocale {} {
3262 variable previousLocale
3263 if {[info commands testlocale] != ""} {
3264 testlocale ctype $previousLocale
3269 # tcltest::threadReap --
3271 # Kill all threads except for the main thread.
3272 # Do nothing if testthread is not defined.
3278 # Returns the number of existing threads.
3284 proc tcltest::threadReap {} {
3285 if {[info commands testthread] != {}} {
3287 # testthread built into tcltest
3289 testthread errorproc ThreadNullError
3290 while {[llength [testthread names]] > 1} {
3291 foreach tid [testthread names] {
3292 if {$tid != [mainThread]} {
3294 testthread send -async $tid {testthread exit}
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
3303 testthread errorproc ThreadError
3304 return [llength [testthread names]]
3305 } elseif {[info commands thread::id] != {}} {
3309 thread::errorproc ThreadNullError
3310 while {[llength [thread::names]] > 1} {
3311 foreach tid [thread::names] {
3312 if {$tid != [mainThread]} {
3313 catch {thread::send -async $tid {thread::exit}}
3316 ## Enter a bit a sleep to give the threads enough breathing
3317 ## room to kill themselves off, otherwise the end up with a
3318 ## massive queue of repeated events
3321 thread::errorproc ThreadError
3322 return [llength [thread::names]]
3329 # Initialize the constraints and set up command line arguments
3330 namespace eval tcltest {
3331 # Define initializers for all the built-in contraint definitions
3332 DefineConstraintInitializers
3334 # Set up the constraints in the testConstraints array to be lazily
3335 # initialized by a registered initializer, or by "false" if no
3336 # initializer is registered.
3337 trace variable testConstraints r [namespace code SafeFetch]
3339 # Only initialize constraints at package load time if an
3340 # [initConstraintsHook] has been pre-defined. This is only
3341 # for compatibility support. The modern way to add a custom
3342 # test constraint is to just call the [testConstraint] command
3343 # straight away, without all this "hook" nonsense.
3344 if {[string equal [namespace current] \
3345 [namespace qualifiers [namespace which initConstraintsHook]]]} {
3348 proc initConstraintsHook {} {}
3351 # Define the standard match commands
3352 customMatch exact [list string equal]
3353 customMatch glob [list string match]
3354 customMatch regexp [list regexp --]
3356 # If the TCLTEST_OPTIONS environment variable exists, configure
3357 # tcltest according to the option values it specifies. This has
3358 # the effect of resetting tcltest's default configuration.
3359 proc ConfigureFromEnvironment {} {
3360 upvar #0 env(TCLTEST_OPTIONS) options
3361 if {[catch {llength $options} msg]} {
3362 Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
3366 if {[llength $options] % 2} {
3367 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
3368 -option value ?-option value ...?"
3371 if {[catch {Configure {*}$options} msg]} {
3372 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
3376 if {[info exists ::env(TCLTEST_OPTIONS)]} {
3377 ConfigureFromEnvironment
3380 proc LoadTimeCmdLineArgParsingRequired {} {
3382 if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
3383 # The command line asks for -help, so give it (and exit)
3384 # right now. ([configure] does not process -help)
3387 foreach hook { PrintUsageInfoHook processCmdLineArgsHook
3388 processCmdLineArgsAddFlagsHook } {
3389 if {[string equal [namespace current] [namespace qualifiers \
3390 [namespace which $hook]]]} {
3399 # Only initialize configurable options from the command line arguments
3400 # at package load time if necessary for backward compatibility. This
3401 # lets the tcltest user call [configure] for themselves if they wish.
3402 # Traces are established for auto-configuration from the command line
3403 # if any configurable options are accessed before the user calls
3405 if {[LoadTimeCmdLineArgParsingRequired]} {
3408 EstablishAutoConfigureTraces
3411 package provide [namespace tail [namespace current]] $Version