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.3
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 set Usage($option) $usage
487 set Verify($option) $verify
488 if {[catch {$verify $value} msg]} {
489 return -code error $msg
491 set Option($option) $msg
493 if {[string length $varName]} {
495 if {[info exists $varName]} {
496 if {[catch {$verify [set $varName]} msg]} {
497 return -code error $msg
499 set Option($option) $msg
503 namespace eval [namespace current] \
504 [list upvar 0 Option($option) $varName]
505 # Workaround for Bug (now Feature Request) 572889. Grrrr....
506 # Track all the variables tied to options
507 lappend OptionControlledVariables $varName
508 # Later, set auto-configure read traces on all
509 # of them, since a single trace on Option does not work.
510 proc $varName {{value {}}} [subst -nocommands {
511 if {[llength [info level 0]] == 2} {
512 Configure $option [set value]
514 return [Configure $option]
519 proc MatchingOption {option} {
521 set match [array names Option $option*]
522 switch -- [llength $match] {
524 set sorted [lsort [array names Option]]
525 set values [join [lrange $sorted 0 end-1] ", "]
526 append values ", or [lindex $sorted end]"
527 return -code error "unknown option $option: should be\
531 return [lindex $match 0]
534 # Exact match trumps ambiguity
535 if {[lsearch -exact $match $option] >= 0} {
538 set values [join [lrange $match 0 end-1] ", "]
539 append values ", or [lindex $match end]"
540 return -code error "ambiguous option $option:\
546 proc EstablishAutoConfigureTraces {} {
547 variable OptionControlledVariables
548 foreach varName [concat $OptionControlledVariables Option] {
550 trace variable $varName r [namespace code {ProcessCmdLineArgs ;#}]
554 proc RemoveAutoConfigureTraces {} {
555 variable OptionControlledVariables
556 foreach varName [concat $OptionControlledVariables Option] {
558 foreach pair [trace vinfo $varName] {
559 foreach {op cmd} $pair break
560 if {[string equal r $op]
561 && [string match *ProcessCmdLineArgs* $cmd]} {
562 trace vdelete $varName $op $cmd
566 # Once the traces are removed, this can become a no-op
567 proc RemoveAutoConfigureTraces {} {}
570 proc Configure args {
573 set n [llength $args]
575 return [lsort [array names Option]]
578 if {[catch {MatchingOption [lindex $args 0]} option]} {
579 return -code error $option
581 return $Option($option)
583 while {[llength $args] > 1} {
584 if {[catch {MatchingOption [lindex $args 0]} option]} {
585 return -code error $option
587 if {[catch {$Verify($option) [lindex $args 1]} value]} {
588 return -code error "invalid $option\
589 value \"[lindex $args 1]\": $value"
591 set Option($option) $value
592 set args [lrange $args 2 end]
594 if {[llength $args]} {
595 if {[catch {MatchingOption [lindex $args 0]} option]} {
596 return -code error $option
598 return -code error "missing value for option $option"
601 proc configure args {
602 RemoveAutoConfigureTraces
603 set code [catch {Configure {*}$args} msg]
604 return -code $code $msg
607 proc AcceptVerbose { level } {
608 set level [AcceptList $level]
609 if {[llength $level] == 1} {
610 if {![regexp {^(pass|body|skip|start|error|line)$} $level]} {
611 # translate single characters abbreviations to expanded list
612 set level [string map {p pass b body s skip t start e error l line} \
618 if {[regexp {^(pass|body|skip|start|error|line)$} $v]} {
625 proc IsVerbose {level} {
627 return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
630 # Default verbosity is to show bodies of failed tests
631 Option -verbose {body error} {
632 Takes any combination of the values 'p', 's', 'b', 't', 'e' and 'l'.
633 Test suite will display all passed tests if 'p' is specified, all
634 skipped tests if 's' is specified, the bodies of failed tests if
635 'b' is specified, and when tests start if 't' is specified.
636 ErrorInfo is displayed if 'e' is specified. Source file line
637 information of failed tests is displayed if 'l' is specified.
638 } AcceptVerbose verbose
640 # Match and skip patterns default to the empty list, except for
641 # matchFiles, which defaults to all .test files in the
642 # testsDirectory and matchDirectories, which defaults to all
645 Run all tests within the specified files that match one of the
646 list of glob patterns given.
650 Skip all tests within the specified tests (via -match) and files
651 that match one of the list of glob patterns given.
654 Option -file *.test {
655 Run tests in all test files that match the glob pattern given.
656 } AcceptPattern matchFiles
658 # By default, skip files that appear to be SCCS lock files.
659 Option -notfile l.*.test {
660 Skip all test files that match the glob pattern given.
661 } AcceptPattern skipFiles
663 Option -relateddir * {
664 Run tests in directories that match the glob pattern given.
665 } AcceptPattern matchDirectories
667 Option -asidefromdir {} {
668 Skip tests in directories that match the glob pattern given.
669 } AcceptPattern skipDirectories
671 # By default, don't save core files
672 Option -preservecore 0 {
673 If 2, save any core files produced during testing in the directory
674 specified by -tmpdir. If 1, notify the user if core files are
676 } AcceptInteger preserveCore
678 # debug output doesn't get printed by default; debug level 1 spits
679 # up only the tests that were skipped because they didn't match or
680 # were specifically skipped. A debug level of 2 would spit up the
681 # tcltest variables and flags provided; a debug level of 3 causes
682 # some additional output regarding operations of the test harness.
683 # The tcltest package currently implements only up to debug level 3.
686 } AcceptInteger debug
688 proc SetSelectedConstraints args {
690 foreach c $Option(-constraints) {
694 Option -constraints {} {
695 Do not skip the listed constraints listed in -constraints.
697 trace variable Option(-constraints) w \
698 [namespace code {SetSelectedConstraints ;#}]
700 # Don't run only the "-constraint" specified tests by default
701 proc ClearUnselectedConstraints args {
703 variable testConstraints
704 if {!$Option(-limitconstraints)} {return}
705 foreach c [array names testConstraints] {
706 if {[lsearch -exact $Option(-constraints) $c] == -1} {
711 Option -limitconstraints false {
712 whether to run only tests with the constraints
713 } AcceptBoolean limitConstraints
714 trace variable Option(-limitconstraints) w \
715 [namespace code {ClearUnselectedConstraints ;#}]
717 # A test application has to know how to load the tested commands
718 # into the interpreter.
720 Specifies the script to load the tested commands.
721 } AcceptScript loadScript
723 # Default is to run each test file in a separate process
724 Option -singleproc 0 {
725 whether to run all tests in one process
726 } AcceptBoolean singleProcess
728 proc AcceptTemporaryDirectory { directory } {
729 set directory [AcceptAbsolutePath $directory]
730 if {![file exists $directory]} {
731 file mkdir $directory
733 set directory [AcceptDirectory $directory]
734 if {![file writable $directory]} {
735 if {[string equal [workingDirectory] $directory]} {
736 # Special exception: accept the default value
737 # even if the directory is not writable
740 return -code error "\"$directory\" is not writeable"
745 # Directory where files should be created
746 Option -tmpdir [workingDirectory] {
747 Save temporary files in the specified directory.
748 } AcceptTemporaryDirectory temporaryDirectory
749 trace variable Option(-tmpdir) w \
750 [namespace code {normalizePath Option(-tmpdir) ;#}]
752 # Tests should not rely on the current working directory.
753 # Files that are part of the test suite should be accessed relative
754 # to [testsDirectory]
755 Option -testdir [workingDirectory] {
756 Search tests in the specified directory.
757 } AcceptDirectory testsDirectory
758 trace variable Option(-testdir) w \
759 [namespace code {normalizePath Option(-testdir) ;#}]
761 proc AcceptLoadFile { file } {
762 if {[string equal "" $file]} {return $file}
763 set file [file join [temporaryDirectory] $file]
764 return [AcceptReadable $file]
766 proc ReadLoadScript {args} {
768 if {[string equal "" $Option(-loadfile)]} {return}
769 set tmp [open $Option(-loadfile) r]
770 loadScript [read $tmp]
773 Option -loadfile {} {
774 Read the script to load the tested commands from the specified file.
775 } AcceptLoadFile loadFile
776 trace variable Option(-loadfile) w [namespace code ReadLoadScript]
778 proc AcceptOutFile { file } {
779 if {[string equal stderr $file]} {return $file}
780 if {[string equal stdout $file]} {return $file}
781 return [file join [temporaryDirectory] $file]
784 # output goes to stdout by default
785 Option -outfile stdout {
786 Send output from test runs to the specified file.
787 } AcceptOutFile outputFile
788 trace variable Option(-outfile) w \
789 [namespace code {outputChannel $Option(-outfile) ;#}]
791 # errors go to stderr by default
792 Option -errfile stderr {
793 Send errors from test runs to the specified file.
794 } AcceptOutFile errorFile
795 trace variable Option(-errfile) w \
796 [namespace code {errorChannel $Option(-errfile) ;#}]
798 proc loadIntoSlaveInterpreter {slave args} {
800 interp eval $slave [package ifneeded tcltest $Version]
801 interp eval $slave "tcltest::configure {*}{$args}"
802 interp alias $slave ::tcltest::ReportToMaster \
803 {} ::tcltest::ReportedFromSlave
805 proc ReportedFromSlave {total passed skipped failed because newfiles} {
807 variable skippedBecause
808 variable createdNewFiles
809 incr numTests(Total) $total
810 incr numTests(Passed) $passed
811 incr numTests(Skipped) $skipped
812 incr numTests(Failed) $failed
813 foreach {constraint count} $because {
814 incr skippedBecause($constraint) $count
816 foreach {testfile created} $newfiles {
817 lappend createdNewFiles($testfile) {*}$created
823 #####################################################################
827 # Internal helper procedures to write out debug information
828 # dependent on the chosen level. A test shell may overide
829 # them, f.e. to redirect the output into a different
830 # channel, or even into a GUI.
832 # tcltest::DebugPuts --
834 # Prints the specified string if the current debug level is
835 # higher than the provided level argument.
838 # level The lowest debug level triggering the output
839 # string The string to print out.
842 # Prints the string. Nothing else is allowed.
848 proc tcltest::DebugPuts {level string} {
850 if {$debug >= $level} {
856 # tcltest::DebugPArray --
858 # Prints the contents of the specified array if the current
859 # debug level is higher than the provided level argument
862 # level The lowest debug level triggering the output
863 # arrayvar The name of the array to print out.
866 # Prints the contents of the array. Nothing else is allowed.
872 proc tcltest::DebugPArray {level arrayvar} {
875 if {$debug >= $level} {
876 catch {upvar $arrayvar $arrayvar}
882 # Define our own [parray] in ::tcltest that will inherit use of the [puts]
883 # defined in ::tcltest. NOTE: Ought to construct with [info args] and
884 # [info default], but can't be bothered now. If [parray] changes, then
885 # this will need changing too.
887 proc tcltest::parray {a {pattern *}} [info body ::parray]
889 # tcltest::DebugDo --
891 # Executes the script if the current debug level is greater than
892 # the provided level argument
895 # level The lowest debug level triggering the execution.
896 # script The tcl script executed upon a debug level high enough.
899 # Arbitrary side effects, dependent on the executed script.
905 proc tcltest::DebugDo {level script} {
908 if {$debug >= $level} {
914 #####################################################################
916 proc tcltest::Warn {msg} {
917 puts [outputChannel] "WARNING: $msg"
920 # tcltest::mainThread
922 # Accessor command for tcltest variable mainThread.
924 proc tcltest::mainThread { {new ""} } {
926 if {[llength [info level 0]] == 1} {
932 # tcltest::testConstraint --
934 # sets a test constraint to a value; to do multiple constraints,
935 # call this proc multiple times. also returns the value of the
936 # named constraint if no value was supplied.
939 # constraint - name of the constraint
940 # value - new value for constraint (should be boolean) - if not
941 # supplied, this is a query
944 # content of tcltest::testConstraints($constraint)
949 proc tcltest::testConstraint {constraint {value ""}} {
950 variable testConstraints
952 DebugPuts 3 "entering testConstraint $constraint $value"
953 if {[llength [info level 0]] == 2} {
954 return $testConstraints($constraint)
956 # Check for boolean values
957 if {[catch {expr {$value && $value}} msg]} {
958 return -code error $msg
960 if {[limitConstraints]
961 && [lsearch -exact $Option(-constraints) $constraint] == -1} {
964 set testConstraints($constraint) $value
967 # tcltest::interpreter --
969 # the interpreter name stored in tcltest::tcltest
975 # content of tcltest::tcltest
980 proc tcltest::interpreter { {interp ""} } {
982 if {[llength [info level 0]] == 1} {
985 if {[string equal {} $interp]} {
992 #####################################################################
994 # tcltest::AddToSkippedBecause --
996 # Increments the variable used to track how many tests were
997 # skipped because of a particular constraint.
1000 # constraint The name of the constraint to be modified
1003 # Modifies tcltest::skippedBecause; sets the variable to 1 if
1004 # didn't previously exist - otherwise, it just increments it.
1009 proc tcltest::AddToSkippedBecause { constraint {value 1}} {
1010 # add the constraint to the list of constraints that kept tests
1012 variable skippedBecause
1014 if {[info exists skippedBecause($constraint)]} {
1015 incr skippedBecause($constraint) $value
1017 set skippedBecause($constraint) $value
1022 # tcltest::PrintError --
1024 # Prints errors to tcltest::errorChannel and then flushes that
1025 # channel, making sure that all messages are < 80 characters per
1029 # errorMsg String containing the error to be printed
1037 proc tcltest::PrintError {errorMsg} {
1038 set InitialMessage "Error: "
1039 set InitialMsgLen [string length $InitialMessage]
1040 puts -nonewline [errorChannel] $InitialMessage
1042 # Keep track of where the end of the string is.
1043 set endingIndex [string length $errorMsg]
1045 if {$endingIndex < (80 - $InitialMsgLen)} {
1046 puts [errorChannel] $errorMsg
1048 # Print up to 80 characters on the first line, including the
1050 set beginningIndex [string last " " [string range $errorMsg 0 \
1051 [expr {80 - $InitialMsgLen}]]]
1052 puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
1054 while {![string equal end $beginningIndex]} {
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]]
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
1072 puts [errorChannel] [string trim \
1073 [string range $errorMsg \
1074 $beginningIndex $newEndingIndex]]
1075 set beginningIndex $newEndingIndex
1079 flush [errorChannel]
1083 # tcltest::SafeFetch --
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.
1093 # n1 - name of the array (testConstraints)
1094 # n2 - array key value (constraint name)
1095 # op - operation performed on testConstraints (generally r)
1101 # sets testConstraints($n2) to 0 if it's referenced but never
1104 proc tcltest::SafeFetch {n1 n2 op} {
1105 variable testConstraints
1106 DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
1107 if {[string equal {} $n2]} {return}
1108 if {![info exists testConstraints($n2)]} {
1109 if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
1110 testConstraint $n2 0
1115 # tcltest::ConstraintInitializer --
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.
1122 # constraint - name of the constraint initialized by the script
1123 # script - the initializer script
1126 # boolean value of the constraint - enabled or disabled
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)
1136 # Check for boolean values
1137 if {![info complete $script]} {
1138 return -code error "ConstraintInitializer must be complete script"
1140 set ConstraintInitializer($constraint) $script
1143 # tcltest::InitConstraints --
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.
1154 # The testConstraints array is reset to have an index for each
1155 # built-in test constraint.
1161 proc tcltest::InitConstraints {} {
1162 variable ConstraintInitializer
1164 foreach constraint [array names ConstraintInitializer] {
1165 testConstraint $constraint
1169 proc tcltest::DefineConstraintInitializers {} {
1170 ConstraintInitializer singleTestInterp {singleProcess}
1172 # All the 'pc' constraints are here for backward compatibility and
1173 # are not documented. They have been replaced with equivalent 'win'
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}
1185 ConstraintInitializer unix {testConstraint unixOnly}
1186 ConstraintInitializer mac {testConstraint macOnly}
1187 ConstraintInitializer pc {testConstraint pcOnly}
1188 ConstraintInitializer win {testConstraint winOnly}
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]}}
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"}
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.
1210 ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
1211 ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
1212 ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
1213 ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
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.
1219 ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
1220 ConstraintInitializer winCrash {expr {![testConstraint win]}}
1221 ConstraintInitializer macCrash {expr {![testConstraint mac]}}
1222 ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
1226 ConstraintInitializer emptyTest {format 0}
1228 # By default, tests that expose known bugs are skipped.
1230 ConstraintInitializer knownBug {format 0}
1232 # By default, non-portable tests are skipped.
1234 ConstraintInitializer nonPortable {format 0}
1236 # Some tests require user interaction.
1238 ConstraintInitializer userInteraction {format 0}
1240 # Some tests must be skipped if the interpreter is not in
1243 ConstraintInitializer interactive \
1244 {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
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.
1251 ConstraintInitializer root {expr \
1252 {[string equal unix $::tcl_platform(platform)]
1253 && ([string equal root $::tcl_platform(user)]
1254 || [string equal "" $::tcl_platform(user)])}}
1255 ConstraintInitializer notRoot {expr {![testConstraint root]}}
1257 # Set nonBlockFiles constraint: 1 means this platform supports
1258 # setting files into nonblocking mode.
1260 ConstraintInitializer nonBlockFiles {
1261 set code [expr {[catch {set f [open defs r]}]
1262 || [catch {fconfigure $f -blocking off}]}]
1267 # Set asyncPipeClose constraint: 1 means this platform supports
1268 # async flush and async close on a pipe.
1270 # Test for SCO Unix - cannot run async flushing tests because a
1271 # potential problem with select is apparently interfering.
1274 ConstraintInitializer asyncPipeClose {expr {
1275 !([string equal unix $::tcl_platform(platform)]
1276 && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
1278 # Test to see if we have a broken version of sprintf with respect
1279 # to the "e" format of floating-point numbers.
1281 ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
1283 # Test to see if execed commands such as cat, echo, rm and so forth
1284 # are present on this machine.
1286 ConstraintInitializer unixExecs {
1288 if {[string equal macintosh $::tcl_platform(platform)]} {
1291 if {[string equal windows $::tcl_platform(platform)]} {
1293 set file _tcl_test_remove_me.txt
1294 makeFile {hello} $file
1298 [catch {exec cat $file}] ||
1299 [catch {exec echo hello}] ||
1300 [catch {exec sh -c echo hello}] ||
1301 [catch {exec wc $file}] ||
1302 [catch {exec sleep 1}] ||
1303 [catch {exec echo abc > $file}] ||
1304 [catch {exec chmod 644 $file}] ||
1305 [catch {exec rm $file}] ||
1306 [llength [auto_execok mkdir]] == 0 ||
1307 [llength [auto_execok fgrep]] == 0 ||
1308 [llength [auto_execok grep]] == 0 ||
1309 [llength [auto_execok ps]] == 0
1318 ConstraintInitializer stdio {
1320 if {![catch {set f [open "|[list [interpreter]]" w]}]} {
1321 if {![catch {puts $f exit}]} {
1322 if {![catch {close $f}]} {
1330 # Deliberately call socket with the wrong number of arguments. The
1331 # error message you get will indicate whether sockets are available
1334 ConstraintInitializer socket {
1336 string compare $msg "sockets are not available on this system"
1339 # Check for internationalization
1340 ConstraintInitializer hasIsoLocale {
1341 if {[llength [info commands testlocale]] == 0} {
1344 set code [string length [SetIso8859_1_Locale]]
1351 #####################################################################
1353 # Usage and command line arguments processing.
1355 # tcltest::PrintUsageInfo
1357 # Prints out the usage information for package tcltest. This can
1358 # be customized with the redefinition of [PrintUsageInfoHook].
1368 proc tcltest::PrintUsageInfo {} {
1373 proc tcltest::Usage { {option ""} } {
1376 if {[llength [info level 0]] == 1} {
1377 set msg "Usage: [file tail [info nameofexecutable]] script "
1378 append msg "?-help? ?flag value? ... \n"
1379 append msg "Available flags (and valid input values) are:"
1382 set allOpts [concat -help [Configure]]
1383 foreach opt $allOpts {
1384 set foo [Usage $opt]
1385 foreach [list x type($opt) usage($opt)] $foo break
1386 set line($opt) " $opt $type($opt) "
1387 set length($opt) [string length $line($opt)]
1388 if {$length($opt) > $max} {set max $length($opt)}
1390 set rest [expr {72 - $max}]
1391 foreach opt $allOpts {
1392 append msg \n$line($opt)
1393 append msg [string repeat " " [expr {$max - $length($opt)}]]
1394 set u [string trim $usage($opt)]
1395 catch {append u " (default: \[[Configure $opt]])"}
1396 regsub -all {\s*\n\s*} $u " " u
1397 while {[string length $u] > $rest} {
1398 set break [string wordstart $u $rest]
1400 set break [string wordend $u 0]
1402 append msg [string range $u 0 [expr {$break - 1}]]
1403 set u [string trim [string range $u $break end]]
1404 append msg \n[string repeat " " $max]
1409 } elseif {[string equal -help $option]} {
1410 return [list -help "" "Display this usage information."]
1412 set type [lindex [info args $Verify($option)] 0]
1413 return [list $option $type $Usage($option)]
1417 # tcltest::ProcessFlags --
1419 # process command line arguments supplied in the flagArray - this
1420 # is called by processCmdLineArgs. Modifies tcltest variables
1421 # according to the content of the flagArray.
1424 # flagArray - array containing name/value pairs of flags
1427 # sets tcltest variables according to their values as defined by
1433 proc tcltest::ProcessFlags {flagArray} {
1434 # Process -help first
1435 if {[lsearch -exact $flagArray {-help}] != -1} {
1440 if {[llength $flagArray] == 0} {
1441 RemoveAutoConfigureTraces
1444 while {[llength $args]>1 && [catch {configure {*}$args} msg]} {
1446 # Something went wrong parsing $args for tcltest options
1447 # Check whether the problem is "unknown option"
1448 if {[regexp {^unknown option (\S+):} $msg -> option]} {
1449 # Could be this is an option the Hook knows about
1450 set moreOptions [processCmdLineArgsAddFlagsHook]
1451 if {[lsearch -exact $moreOptions $option] == -1} {
1452 # Nope. Report the error, including additional options,
1454 if {[llength $moreOptions]} {
1456 append msg [join [lrange $moreOptions 0 end-1] ", "]
1457 append msg "or [lindex $moreOptions end]"
1462 # error is something other than "unknown option"
1463 # notify user of the error; and exit
1464 puts [errorChannel] $msg
1468 # To recover, find that unknown option and remove up to it.
1470 while {![string equal [lindex $args 0] $option]} {
1471 set args [lrange $args 2 end]
1473 set args [lrange $args 2 end]
1475 if {[llength $args] == 1} {
1476 puts [errorChannel] \
1477 "missing value for option [lindex $args 0]"
1484 array set flag $flagArray
1485 processCmdLineArgsHook [array get flag]
1490 # tcltest::ProcessCmdLineArgs --
1492 # This procedure must be run after constraint initialization is
1493 # set up (by [DefineConstraintInitializers]) because some constraints
1494 # can be overridden.
1496 # Perform configuration according to the command-line options.
1502 # Sets the above-named variables in the tcltest namespace.
1508 proc tcltest::ProcessCmdLineArgs {} {
1509 variable originalEnv
1510 variable testConstraints
1512 # The "argv" var doesn't exist in some cases, so use {}.
1513 if {![info exists ::argv]} {
1516 ProcessFlags $::argv
1519 # Spit out everything you know if we're at a debug level 2 or
1521 DebugPuts 2 "Flags passed into tcltest:"
1522 if {[info exists ::env(TCLTEST_OPTIONS)]} {
1524 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
1526 if {[info exists ::argv]} {
1527 DebugPuts 2 " argv: $::argv"
1529 DebugPuts 2 "tcltest::debug = [debug]"
1530 DebugPuts 2 "tcltest::testsDirectory = [testsDirectory]"
1531 DebugPuts 2 "tcltest::workingDirectory = [workingDirectory]"
1532 DebugPuts 2 "tcltest::temporaryDirectory = [temporaryDirectory]"
1533 DebugPuts 2 "tcltest::outputChannel = [outputChannel]"
1534 DebugPuts 2 "tcltest::errorChannel = [errorChannel]"
1535 DebugPuts 2 "Original environment (tcltest::originalEnv):"
1536 DebugPArray 2 originalEnv
1537 DebugPuts 2 "Constraints:"
1538 DebugPArray 2 testConstraints
1541 #####################################################################
1543 # Code to run the tests goes here.
1545 # tcltest::TestPuts --
1547 # Used to redefine puts in test environment. Stores whatever goes
1548 # out on stdout in tcltest::outData and stderr in errData before
1549 # sending it on to the regular puts.
1552 # same as standard puts
1558 # Intercepts puts; data that would otherwise go to stdout, stderr,
1559 # or file channels specified in outputChannel and errorChannel
1560 # does not get sent to the normal puts function.
1561 namespace eval tcltest::Replace {
1562 namespace export puts
1564 proc tcltest::Replace::puts {args} {
1565 variable [namespace parent]::outData
1566 variable [namespace parent]::errData
1567 switch [llength $args] {
1569 # Only the string to be printed is specified
1570 append outData [lindex $args 0]\n
1572 # return [Puts [lindex $args 0]]
1575 # Either -nonewline or channelId has been specified
1576 if {[string equal -nonewline [lindex $args 0]]} {
1577 append outData [lindex $args end]
1579 # return [Puts -nonewline [lindex $args end]]
1581 set channel [lindex $args 0]
1586 if {[string equal -nonewline [lindex $args 0]]} {
1587 # Both -nonewline and channelId are specified, unless
1588 # it's an error. -nonewline is supposed to be argv[0].
1589 set channel [lindex $args 1]
1595 if {[info exists channel]} {
1596 if {[string equal $channel [[namespace parent]::outputChannel]]
1597 || [string equal $channel stdout]} {
1598 append outData [lindex $args end]$newline
1600 } elseif {[string equal $channel [[namespace parent]::errorChannel]]
1601 || [string equal $channel stderr]} {
1602 append errData [lindex $args end]$newline
1607 # If we haven't returned by now, we don't know how to handle the
1608 # input. Let puts handle it.
1609 return [Puts {*}$args]
1614 # Evaluate the script in the test environment. If ignoreOutput is
1615 # false, store data sent to stderr and stdout in outData and
1616 # errData. Otherwise, ignore this output altogether.
1619 # script Script to evaluate
1620 # ?ignoreOutput? Indicates whether or not to ignore output
1621 # sent to stdout & stderr
1624 # result from running the script
1627 # Empties the contents of outData and errData before running a
1628 # test if ignoreOutput is set to 0.
1630 proc tcltest::Eval {script {ignoreOutput 1}} {
1633 DebugPuts 3 "[lindex [info level 0] 0] called"
1634 if {!$ignoreOutput} {
1637 rename ::puts [namespace current]::Replace::Puts
1638 namespace eval :: [list namespace import [namespace origin Replace::puts]]
1639 namespace import Replace::puts
1641 set result [uplevel 1 $script]
1642 if {!$ignoreOutput} {
1643 namespace forget puts
1644 namespace eval :: namespace forget puts
1645 rename [namespace current]::Replace::Puts ::puts
1650 # tcltest::CompareStrings --
1652 # compares the expected answer to the actual answer, depending on
1653 # the mode provided. Mode determines whether a regexp, exact,
1654 # glob or custom comparison is done.
1657 # actual - string containing the actual result
1658 # expected - pattern to be matched against
1659 # mode - type of comparison to be done
1662 # result of the match
1667 proc tcltest::CompareStrings {actual expected mode} {
1668 variable CustomMatch
1669 if {![info exists CustomMatch($mode)]} {
1670 return -code error "No matching command registered for `-match $mode'"
1672 set match [namespace eval :: $CustomMatch($mode) [list $expected $actual]]
1673 if {[catch {expr {$match && $match}} result]} {
1674 return -code error "Invalid result from `-match $mode' command: $result"
1679 # tcltest::customMatch --
1681 # registers a command to be called when a particular type of
1682 # matching is required.
1685 # nickname - Keyword for the type of matching
1686 # cmd - Incomplete command that implements that type of matching
1687 # when completed with expected string and actual string
1688 # and then evaluated.
1694 # Sets the variable tcltest::CustomMatch
1696 proc tcltest::customMatch {mode script} {
1697 variable CustomMatch
1698 if {![info complete $script]} {
1699 return -code error \
1700 "invalid customMatch script; can't evaluate after completion"
1702 set CustomMatch($mode) $script
1705 # tcltest::SubstArguments list
1707 # This helper function takes in a list of words, then perform a
1708 # substitution on the list as though each word in the list is a separate
1709 # argument to the Tcl function. For example, if this function is
1712 # SubstArguments {$a {$a}}
1714 # Then it is as though the function is invoked as:
1716 # SubstArguments $a {$a}
1718 # This code is adapted from Paul Duffin's function "SplitIntoWords".
1719 # The original function can be found on:
1721 # http://purl.org/thecliff/tcl/wiki/858.html
1724 # a list containing the result of the substitution
1727 # An error may occur if the list containing unbalanced quote or
1734 proc tcltest::SubstArguments {argList} {
1736 # We need to split the argList up into tokens but cannot use list
1737 # operations as they throw away some significant quoting, and
1738 # [split] ignores braces as it should. Therefore what we do is
1739 # gradually build up a string out of whitespace seperated strings.
1740 # We cannot use [split] to split the argList into whitespace
1741 # separated strings as it throws away the whitespace which maybe
1742 # important so we have to do it all by hand.
1747 while {[string length $argList]} {
1748 # Look for the next word containing a quote: " { }
1749 if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
1751 # Get the text leading up to this word, but not including
1752 # this word, from the argList.
1753 set text [string range $argList 0 \
1754 [expr {[lindex $all 0] - 1}]]
1755 # Get the word with the quote
1756 set word [string range $argList \
1757 [lindex $all 0] [lindex $all 1]]
1759 # Remove all text up to and including the word from the
1761 set argList [string range $argList \
1762 [expr {[lindex $all 1] + 1}] end]
1764 # Take everything up to the end of the argList.
1771 # If we saw a word with quote before, then there is a
1772 # multi-word token starting with that word. In this case,
1773 # add the text and the current word to this token.
1774 append token $text $word
1776 # Add the text to the result. There is no need to parse
1777 # the text because it couldn't be a part of any multi-word
1778 # token. Then start a new multi-word token with the word
1779 # because we need to pass this token to the Tcl parser to
1780 # check for balancing quotes
1785 if { [catch {llength $token} length] == 0 && $length == 1} {
1786 # The token is a valid list so add it to the result.
1787 # lappend result [string trim $token]
1788 append result \{$token\}
1793 # If the last token has not been added to the list then there
1795 if { [string length $token] } {
1796 error "incomplete token \"$token\""
1805 # This procedure runs a test and prints an error message if the test
1806 # fails. If verbose has been set, it also prints a message even if the
1807 # test succeeds. The test will be skipped if it doesn't match the
1808 # match variable, if it matches an element in skip, or if one of the
1809 # elements of "constraints" turns out not to be true.
1811 # If testLevel is 1, then this is a top level test, and we record
1812 # pass/fail information; otherwise, this information is not logged and
1813 # is not added to running totals.
1816 # Only description is a required attribute. All others are optional.
1817 # Default values are indicated.
1819 # constraints - A list of one or more keywords, each of which
1820 # must be the name of an element in the array
1821 # "testConstraints". If any of these elements is
1822 # zero, the test is skipped. This attribute is
1823 # optional; default is {}
1824 # body - Script to run to carry out the test. It must
1825 # return a result that can be checked for
1826 # correctness. This attribute is optional;
1828 # result - Expected result from script. This attribute is
1829 # optional; default is {}.
1830 # output - Expected output sent to stdout. This attribute
1831 # is optional; default is {}.
1832 # errorOutput - Expected output sent to stderr. This attribute
1833 # is optional; default is {}.
1834 # returnCodes - Expected return codes. This attribute is
1835 # optional; default is {0 2}.
1836 # setup - Code to run before $script (above). This
1837 # attribute is optional; default is {}.
1838 # cleanup - Code to run after $script (above). This
1839 # attribute is optional; default is {}.
1840 # match - specifies type of matching to do on result,
1841 # output, errorOutput; this must be a string
1842 # previously registered by a call to [customMatch].
1843 # The strings exact, glob, and regexp are pre-registered
1844 # by the tcltest package. Default value is exact.
1847 # name - Name of test, in the form foo-1.2.
1848 # description - Short textual description of the test, to
1849 # help humans understand what it does.
1855 # Just about anything is possible depending on the test.
1858 proc tcltest::test {name description args} {
1861 variable coreModTime
1862 DebugPuts 3 "test $name $args"
1866 puts "test name '$name' re-used; prior use in $TestNames($name)"
1868 set TestNames($name) [info script]
1874 # Pre-define everything to null except output and errorOutput. We
1875 # determine whether or not to trap output based on whether or not
1876 # these variables (output & errorOutput) are defined.
1877 foreach item {constraints setup cleanup body result returnCodes
1882 # Set the default match mode
1885 # Set the default match values for return codes (0 is the standard
1886 # expected return value if everything went well; 2 represents
1887 # 'return' being used in the test script).
1888 set returnCodes [list 0 2]
1890 # The old test format can't have a 3rd argument (constraints or
1891 # script) that starts with '-'.
1892 if {[string match -* [lindex $args 0]]
1893 || ([llength $args] <= 1)} {
1894 if {[llength $args] == 1} {
1895 set list [SubstArguments [lindex $args 0]]
1896 foreach {element value} $list {
1897 set testAttributes($element) $value
1899 foreach item {constraints match setup body cleanup \
1900 result returnCodes output errorOutput} {
1901 if {[info exists testAttributes(-$item)]} {
1902 set testAttributes(-$item) [uplevel 1 \
1903 ::concat $testAttributes(-$item)]
1907 array set testAttributes $args
1910 set validFlags {-setup -cleanup -body -result -returnCodes \
1911 -match -output -errorOutput -constraints}
1913 foreach flag [array names testAttributes] {
1914 if {[lsearch -exact $validFlags $flag] == -1} {
1916 set sorted [lsort $validFlags]
1917 set options [join [lrange $sorted 0 end-1] ", "]
1918 append options ", or [lindex $sorted end]"
1919 return -code error "bad option \"$flag\": must be $options"
1923 # store whatever the user gave us
1924 foreach item [array names testAttributes] {
1925 set [string trimleft $item "-"] $testAttributes($item)
1928 # Check the values supplied for -match
1929 variable CustomMatch
1930 if {[lsearch [array names CustomMatch] $match] == -1} {
1932 set sorted [lsort [array names CustomMatch]]
1933 set values [join [lrange $sorted 0 end-1] ", "]
1934 append values ", or [lindex $sorted end]"
1935 return -code error "bad -match value \"$match\":\
1939 # Replace symbolic valies supplied for -returnCodes
1940 foreach {strcode numcode} {ok 0 normal 0 error 1 return 2 break 3 continue 4} {
1941 set returnCodes [string map -nocase [list $strcode $numcode] $returnCodes]
1944 # This is parsing for the old test command format; it is here
1945 # for backward compatibility.
1946 set result [lindex $args end]
1947 if {[llength $args] == 2} {
1948 set body [lindex $args 0]
1949 } elseif {[llength $args] == 3} {
1950 set constraints [lindex $args 0]
1951 set body [lindex $args 1]
1954 return -code error "wrong # args:\
1955 should be \"test name desc ?options?\""
1959 if {[Skipped $name $constraints]} {
1964 # Save information about the core file.
1965 if {[preserveCore]} {
1966 if {[file exists [file join [workingDirectory] core]]} {
1967 set coreModTime [file mtime [file join [workingDirectory] core]]
1971 # First, run the setup script
1972 set code [catch {uplevel 1 $setup} setupMsg]
1974 set errorInfo(setup) $::errorInfo
1975 set errorCode(setup) $::errorCode
1977 set setupFailure [expr {$code != 0}]
1979 # Only run the test body if the setup was successful
1980 if {!$setupFailure} {
1982 # Verbose notification of $body start
1983 if {[IsVerbose start]} {
1984 puts [outputChannel] "---- $name start"
1985 flush [outputChannel]
1988 set command [list [namespace origin RunTest] $name $body]
1989 if {[info exists output] || [info exists errorOutput]} {
1990 set testResult [uplevel 1 [list [namespace origin Eval] $command 0]]
1992 set testResult [uplevel 1 [list [namespace origin Eval] $command 1]]
1994 foreach {actualAnswer returnCode} $testResult break
1995 if {$returnCode == 1} {
1996 set errorInfo(body) $::errorInfo
1997 set errorCode(body) $::errorCode
2001 # Always run the cleanup script
2002 set code [catch {uplevel 1 $cleanup} cleanupMsg]
2004 set errorInfo(cleanup) $::errorInfo
2005 set errorCode(cleanup) $::errorCode
2007 set cleanupFailure [expr {$code != 0}]
2011 # check for a core file first - if one was created by the test,
2012 # then the test failed
2013 if {[preserveCore]} {
2014 if {[file exists [file join [workingDirectory] core]]} {
2015 # There's only a test failure if there is a core file
2016 # and (1) there previously wasn't one or (2) the new
2017 # one is different from the old one.
2018 if {[info exists coreModTime]} {
2019 if {$coreModTime != [file mtime \
2020 [file join [workingDirectory] core]]} {
2027 if {([preserveCore] > 1) && ($coreFailure)} {
2028 append coreMsg "\nMoving file to:\
2029 [file join [temporaryDirectory] core-$name]"
2030 catch {file rename -force \
2031 [file join [workingDirectory] core] \
2032 [file join [temporaryDirectory] core-$name]
2034 if {[string length $msg] > 0} {
2035 append coreMsg "\nError:\
2036 Problem renaming core file: $msg"
2042 # check if the return code matched the expected return code
2044 if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
2048 # If expected output/error strings exist, we have to compare
2049 # them. If the comparison fails, then so did the test.
2052 if {[info exists output] && !$codeFailure} {
2053 if {[set outputCompare [catch {
2054 CompareStrings $outData $output $match
2055 } outputMatch]] == 0} {
2056 set outputFailure [expr {!$outputMatch}]
2064 if {[info exists errorOutput] && !$codeFailure} {
2065 if {[set errorCompare [catch {
2066 CompareStrings $errData $errorOutput $match
2067 } errorMatch]] == 0} {
2068 set errorFailure [expr {!$errorMatch}]
2074 # check if the answer matched the expected answer
2075 # Only check if we ran the body of the test (no setup failure)
2076 if {$setupFailure || $codeFailure} {
2078 } elseif {[set scriptCompare [catch {
2079 CompareStrings $actualAnswer $result $match
2080 } scriptMatch]] == 0} {
2081 set scriptFailure [expr {!$scriptMatch}]
2086 # if we didn't experience any failures, then we passed
2088 if {!($setupFailure || $cleanupFailure || $coreFailure
2089 || $outputFailure || $errorFailure || $codeFailure
2090 || $scriptFailure)} {
2091 if {$testLevel == 1} {
2092 incr numTests(Passed)
2093 if {[IsVerbose pass]} {
2094 puts [outputChannel] "++++ $name PASSED"
2101 # We know the test failed, tally it...
2102 if {$testLevel == 1} {
2103 incr numTests(Failed)
2106 # ... then report according to the type of failure
2107 variable currentFailure true
2108 if {![IsVerbose body]} {
2111 puts [outputChannel] "\n"
2112 if {[IsVerbose line]} {
2113 if {![catch {set testFrame [info frame -1]}] &&
2114 [dict get $testFrame type] eq "source"} {
2115 set testFile [dict get $testFrame file]
2116 set testLine [dict get $testFrame line]
2118 set testFile [file normalize [uplevel 1 {info script}]]
2119 if {[file readable $testFile]} {
2120 set testFd [open $testFile r]
2121 set testLine [expr {[lsearch -regexp \
2122 [split [read $testFd] "\n"] \
2123 "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
2127 if {[info exists testLine]} {
2128 puts [outputChannel] "$testFile:$testLine: error: test failed:\
2129 $name [string trim $description]"
2132 puts [outputChannel] "==== $name\
2133 [string trim $description] FAILED"
2134 if {[string length $body]} {
2135 puts [outputChannel] "==== Contents of test case:"
2136 puts [outputChannel] $body
2138 if {$setupFailure} {
2139 puts [outputChannel] "---- Test setup\
2141 if {[info exists errorInfo(setup)]} {
2142 puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
2143 puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
2146 if {$scriptFailure} {
2147 if {$scriptCompare} {
2148 puts [outputChannel] "---- Error testing result: $scriptMatch"
2150 puts [outputChannel] "---- Result was:\n$actualAnswer"
2151 puts [outputChannel] "---- Result should have been\
2152 ($match matching):\n$result"
2156 switch -- $returnCode {
2157 0 { set msg "Test completed normally" }
2158 1 { set msg "Test generated error" }
2159 2 { set msg "Test generated return exception" }
2160 3 { set msg "Test generated break exception" }
2161 4 { set msg "Test generated continue exception" }
2162 default { set msg "Test generated exception" }
2164 puts [outputChannel] "---- $msg; Return code was: $returnCode"
2165 puts [outputChannel] "---- Return code should have been\
2166 one of: $returnCodes"
2167 if {[IsVerbose error]} {
2168 if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
2169 puts [outputChannel] "---- errorInfo: $errorInfo(body)"
2170 puts [outputChannel] "---- errorCode: $errorCode(body)"
2174 if {$outputFailure} {
2175 if {$outputCompare} {
2176 puts [outputChannel] "---- Error testing output: $outputMatch"
2178 puts [outputChannel] "---- Output was:\n$outData"
2179 puts [outputChannel] "---- Output should have been\
2180 ($match matching):\n$output"
2183 if {$errorFailure} {
2184 if {$errorCompare} {
2185 puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
2187 puts [outputChannel] "---- Error output was:\n$errData"
2188 puts [outputChannel] "---- Error output should have\
2189 been ($match matching):\n$errorOutput"
2192 if {$cleanupFailure} {
2193 puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
2194 if {[info exists errorInfo(cleanup)]} {
2195 puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
2196 puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
2200 puts [outputChannel] "---- Core file produced while running\
2203 puts [outputChannel] "==== $name FAILED\n"
2211 # Given a test name and it constraints, returns a boolean indicating
2212 # whether the current configuration says the test should be skipped.
2214 # Side Effects: Maintains tally of total tests seen and tests skipped.
2216 proc tcltest::Skipped {name constraints} {
2219 variable testConstraints
2221 if {$testLevel == 1} {
2222 incr numTests(Total)
2224 # skip the test if it's name matches an element of skip
2225 foreach pattern [skip] {
2226 if {[string match $pattern $name]} {
2227 if {$testLevel == 1} {
2228 incr numTests(Skipped)
2229 DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
2234 # skip the test if it's name doesn't match any element of match
2236 foreach pattern [match] {
2237 if {[string match $pattern $name]} {
2243 if {$testLevel == 1} {
2244 incr numTests(Skipped)
2245 DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
2249 if {[string equal {} $constraints]} {
2250 # If we're limited to the listed constraints and there aren't
2251 # any listed, then we shouldn't run the test.
2252 if {[limitConstraints]} {
2253 AddToSkippedBecause userSpecifiedLimitConstraint
2254 if {$testLevel == 1} {
2255 incr numTests(Skipped)
2260 # "constraints" argument exists;
2261 # make sure that the constraints are satisfied.
2264 if {[string match {*[$\[]*} $constraints] != 0} {
2265 # full expression, e.g. {$foo > [info tclversion]}
2266 catch {set doTest [uplevel #0 [list expr $constraints]]}
2267 } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
2268 # something like {a || b} should be turned into
2269 # $testConstraints(a) || $testConstraints(b).
2270 regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
2271 catch {set doTest [eval [list expr $c]]}
2272 } elseif {![catch {llength $constraints}]} {
2273 # just simple constraints such as {unixOnly fonts}.
2275 foreach constraint $constraints {
2276 if {(![info exists testConstraints($constraint)]) \
2277 || (!$testConstraints($constraint))} {
2280 # store the constraint that kept the test from
2282 set constraints $constraint
2289 if {[IsVerbose skip]} {
2290 puts [outputChannel] "++++ $name SKIPPED: $constraints"
2293 if {$testLevel == 1} {
2294 incr numTests(Skipped)
2295 AddToSkippedBecause $constraints
2305 # This is where the body of a test is evaluated. The combination of
2306 # [RunTest] and [Eval] allows the output and error output of the test
2307 # body to be captured for comparison against the expected values.
2309 proc tcltest::RunTest {name script} {
2310 DebugPuts 3 "Running $name {$script}"
2312 # If there is no "memory" command (because memory debugging isn't
2313 # enabled), then don't attempt to use the command.
2315 if {[llength [info commands memory]] == 1} {
2319 set code [catch {uplevel 1 $script} actualAnswer]
2321 return [list $actualAnswer $code]
2324 #####################################################################
2326 # tcltest::cleanupTestsHook --
2328 # This hook allows a harness that builds upon tcltest to specify
2329 # additional things that should be done at cleanup.
2332 if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
2333 proc tcltest::cleanupTestsHook {} {}
2336 # tcltest::cleanupTests --
2338 # Remove files and dirs created using the makeFile and makeDirectory
2339 # commands since the last time this proc was invoked.
2341 # Print the names of the files created without the makeFile command
2342 # since the tests were invoked.
2344 # Print the number tests (total, passed, failed, and skipped) since the
2345 # tests were invoked.
2347 # Restore original environment (as reported by special variable env).
2350 # calledFromAllFile - if 0, behave as if we are running a single
2351 # test file within an entire suite of tests. if we aren't running
2352 # a single test file, then don't report status. check for new
2353 # files created during the test run and report on them. if 1,
2354 # report collated status from all the test file runs.
2363 proc tcltest::cleanupTests {{calledFromAllFile 0}} {
2365 variable filesExisted
2366 variable createdNewFiles
2367 variable testSingleFile
2369 variable numTestFiles
2371 variable skippedBecause
2372 variable currentFailure
2373 variable originalEnv
2374 variable originalTclPlatform
2375 variable coreModTime
2378 set testFileName [file tail [info script]]
2380 # Hook to handle reporting to a parent interpreter
2381 if {[llength [info commands [namespace current]::ReportToMaster]]} {
2382 ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
2383 $numTests(Failed) [array get skippedBecause] \
2384 [array get createdNewFiles]
2385 set testSingleFile false
2388 # Call the cleanup hook
2391 # Remove files and directories created by the makeFile and
2392 # makeDirectory procedures. Record the names of files in
2393 # workingDirectory that were not pre-existing, and associate them
2394 # with the test file that created them.
2396 if {!$calledFromAllFile} {
2397 foreach file $filesMade {
2398 if {[file exists $file]} {
2399 DebugDo 1 {Warn "cleanupTests deleting $file..."}
2400 catch {file delete -force $file}
2404 foreach file [glob -nocomplain \
2405 -directory [temporaryDirectory] *] {
2406 lappend currentFiles [file tail $file]
2409 foreach file $currentFiles {
2410 if {[lsearch -exact $filesExisted $file] == -1} {
2411 lappend newFiles $file
2414 set filesExisted $currentFiles
2415 if {[llength $newFiles] > 0} {
2416 set createdNewFiles($testFileName) $newFiles
2420 if {$calledFromAllFile || $testSingleFile} {
2424 puts -nonewline [outputChannel] "$testFileName:"
2425 foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2426 puts -nonewline [outputChannel] \
2427 "\t$index\t$numTests($index)"
2429 puts [outputChannel] ""
2431 # print number test files sourced
2432 # print names of files that ran tests which failed
2434 if {$calledFromAllFile} {
2435 puts [outputChannel] \
2436 "Sourced $numTestFiles Test Files."
2438 if {[llength $failFiles] > 0} {
2439 puts [outputChannel] \
2440 "Files with failing tests: $failFiles"
2445 # if any tests were skipped, print the constraints that kept
2446 # them from running.
2448 set constraintList [array names skippedBecause]
2449 if {[llength $constraintList] > 0} {
2450 puts [outputChannel] \
2451 "Number of tests skipped for each constraint:"
2452 foreach constraint [lsort $constraintList] {
2453 puts [outputChannel] \
2454 "\t$skippedBecause($constraint)\t$constraint"
2455 unset skippedBecause($constraint)
2459 # report the names of test files in createdNewFiles, and reset
2460 # the array to be empty.
2462 set testFilesThatTurded [lsort [array names createdNewFiles]]
2463 if {[llength $testFilesThatTurded] > 0} {
2464 puts [outputChannel] "Warning: files left behind:"
2465 foreach testFile $testFilesThatTurded {
2466 puts [outputChannel] \
2467 "\t$testFile:\t$createdNewFiles($testFile)"
2468 unset createdNewFiles($testFile)
2472 # reset filesMade, filesExisted, and numTests
2475 foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2476 set numTests($index) 0
2479 # exit only if running Tk in non-interactive mode
2480 # This should be changed to determine if an event
2481 # loop is running, which is the real issue.
2482 # Actually, this doesn't belong here at all. A package
2483 # really has no business [exit]-ing an application.
2484 if {![catch {package present Tk}] && ![testConstraint interactive]} {
2489 # if we're deferring stat-reporting until all files are sourced,
2490 # then add current file to failFile list if any tests in this
2493 if {$currentFailure \
2494 && ([lsearch -exact $failFiles $testFileName] == -1)} {
2495 lappend failFiles $testFileName
2497 set currentFailure false
2499 # restore the environment to the state it was in before this package
2505 foreach index [array names ::env] {
2506 if {![info exists originalEnv($index)]} {
2507 lappend newEnv $index
2510 if {$::env($index) != $originalEnv($index)} {
2511 lappend changedEnv $index
2512 set ::env($index) $originalEnv($index)
2516 foreach index [array names originalEnv] {
2517 if {![info exists ::env($index)]} {
2518 lappend removedEnv $index
2519 set ::env($index) $originalEnv($index)
2522 if {[llength $newEnv] > 0} {
2523 puts [outputChannel] \
2524 "env array elements created:\t$newEnv"
2526 if {[llength $changedEnv] > 0} {
2527 puts [outputChannel] \
2528 "env array elements changed:\t$changedEnv"
2530 if {[llength $removedEnv] > 0} {
2531 puts [outputChannel] \
2532 "env array elements removed:\t$removedEnv"
2535 set changedTclPlatform {}
2536 foreach index [array names originalTclPlatform] {
2537 if {$::tcl_platform($index) \
2538 != $originalTclPlatform($index)} {
2539 lappend changedTclPlatform $index
2540 set ::tcl_platform($index) $originalTclPlatform($index)
2543 if {[llength $changedTclPlatform] > 0} {
2544 puts [outputChannel] "tcl_platform array elements\
2545 changed:\t$changedTclPlatform"
2548 if {[file exists [file join [workingDirectory] core]]} {
2549 if {[preserveCore] > 1} {
2550 puts "rename core file (> 1)"
2551 puts [outputChannel] "produced core file! \
2553 [file join [temporaryDirectory] core-$testFileName]"
2554 catch {file rename -force \
2555 [file join [workingDirectory] core] \
2556 [file join [temporaryDirectory] core-$testFileName]
2558 if {[string length $msg] > 0} {
2559 PrintError "Problem renaming file: $msg"
2562 # Print a message if there is a core file and (1) there
2563 # previously wasn't one or (2) the new one is different
2566 if {[info exists coreModTime]} {
2567 if {$coreModTime != [file mtime \
2568 [file join [workingDirectory] core]]} {
2569 puts [outputChannel] "A core file was created!"
2572 puts [outputChannel] "A core file was created!"
2577 flush [outputChannel]
2578 flush [errorChannel]
2582 #####################################################################
2584 # Procs that determine which tests/test files to run
2586 # tcltest::GetMatchingFiles
2588 # Looks at the patterns given to match and skip files and uses
2589 # them to put together a list of the tests that will be run.
2592 # directory to search
2595 # The constructed list is returned to the user. This will
2596 # primarily be used in 'all.tcl' files. It is used in
2602 # a lower case version is needed for compatibility with tcltest 1.0
2603 proc tcltest::getMatchingFiles args {GetMatchingFiles {*}$args}
2605 proc tcltest::GetMatchingFiles { args } {
2606 if {[llength $args]} {
2609 # Finding tests only in [testsDirectory] is normal operation.
2610 # This procedure is written to accept multiple directory arguments
2611 # only to satisfy version 1 compatibility.
2612 set dirList [list [testsDirectory]]
2615 set matchingFiles [list]
2616 foreach directory $dirList {
2618 # List files in $directory that match patterns to run.
2619 set matchFileList [list]
2620 foreach match [matchFiles] {
2621 set matchFileList [concat $matchFileList \
2622 [glob -directory $directory -types {b c f p s} \
2623 -nocomplain -- $match]]
2626 # List files in $directory that match patterns to skip.
2627 set skipFileList [list]
2628 foreach skip [skipFiles] {
2629 set skipFileList [concat $skipFileList \
2630 [glob -directory $directory -types {b c f p s} \
2631 -nocomplain -- $skip]]
2634 # Add to result list all files in match list and not in skip list
2635 foreach file $matchFileList {
2636 if {[lsearch -exact $skipFileList $file] == -1} {
2637 lappend matchingFiles $file
2642 if {[llength $matchingFiles] == 0} {
2643 PrintError "No test files remain after applying your match and\
2646 return $matchingFiles
2649 # tcltest::GetMatchingDirectories --
2651 # Looks at the patterns given to match and skip directories and
2652 # uses them to put together a list of the test directories that we
2653 # should attempt to run. (Only subdirectories containing an
2654 # "all.tcl" file are put into the list.)
2657 # root directory from which to search
2660 # The constructed list is returned to the user. This is used in
2661 # the primary all.tcl file.
2666 proc tcltest::GetMatchingDirectories {rootdir} {
2668 # Determine the skip list first, to avoid [glob]-ing over subdirectories
2669 # we're going to throw away anyway. Be sure we skip the $rootdir if it
2670 # comes up to avoid infinite loops.
2671 set skipDirs [list $rootdir]
2672 foreach pattern [skipDirectories] {
2673 set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
2674 -nocomplain -- $pattern]]
2677 # Now step through the matching directories, prune out the skipped ones
2679 set matchDirs [list]
2680 foreach pattern [matchDirectories] {
2681 foreach path [glob -directory $rootdir -types d -nocomplain -- \
2683 if {[lsearch -exact $skipDirs $path] == -1} {
2684 set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
2685 if {[file exists [file join $path all.tcl]]} {
2686 lappend matchDirs $path
2692 if {[llength $matchDirs] == 0} {
2693 DebugPuts 1 "No test directories remain after applying match\
2699 # tcltest::runAllTests --
2701 # prints output and sources test files according to the match and
2702 # skip patterns provided. after sourcing test files, it goes on
2703 # to source all.tcl files in matching test subdirectories.
2706 # shell being tested
2714 proc tcltest::runAllTests { {shell ""} } {
2715 variable testSingleFile
2716 variable numTestFiles
2721 if {[llength [info level 0]] == 1} {
2722 set shell [interpreter]
2725 set testSingleFile false
2727 puts [outputChannel] "Tests running in interp: $shell"
2728 puts [outputChannel] "Tests located in: [testsDirectory]"
2729 puts [outputChannel] "Tests running in: [workingDirectory]"
2730 puts [outputChannel] "Temporary files stored in\
2731 [temporaryDirectory]"
2733 # [file system] first available in Tcl 8.4
2734 if {![catch {file system [testsDirectory]} result]
2735 && ![string equal native [lindex $result 0]]} {
2736 # If we aren't running in the native filesystem, then we must
2737 # run the tests in a single process (via 'source'), because
2738 # trying to run then via a pipe will fail since the files don't
2743 if {[singleProcess]} {
2744 puts [outputChannel] \
2745 "Test files sourced into current interpreter"
2747 puts [outputChannel] \
2748 "Test files run in separate interpreters"
2750 if {[llength [skip]] > 0} {
2751 puts [outputChannel] "Skipping tests that match: [skip]"
2753 puts [outputChannel] "Running tests that match: [match]"
2755 if {[llength [skipFiles]] > 0} {
2756 puts [outputChannel] \
2757 "Skipping test files that match: [skipFiles]"
2759 if {[llength [matchFiles]] > 0} {
2760 puts [outputChannel] \
2761 "Only running test files that match: [matchFiles]"
2764 set timeCmd {clock format [clock seconds]}
2765 puts [outputChannel] "Tests began at [eval $timeCmd]"
2767 # Run each of the specified tests
2768 foreach file [lsort [GetMatchingFiles]] {
2769 set tail [file tail $file]
2770 puts [outputChannel] $tail
2771 flush [outputChannel]
2773 if {[singleProcess]} {
2775 uplevel 1 [list ::source $file]
2777 # Pass along our configuration to the child processes.
2778 # EXCEPT for the -outfile, because the parent process
2779 # needs to read and process output of children.
2780 set childargv [list]
2781 foreach opt [Configure] {
2782 if {[string equal $opt -outfile]} {continue}
2783 lappend childargv $opt [Configure $opt]
2785 set cmd [linsert $childargv 0 | $shell $file]
2788 set pipeFd [open $cmd "r"]
2789 while {[gets $pipeFd line] >= 0} {
2793 {Passed\t([0-9]+)\t}
2794 {Skipped\t([0-9]+)\t}
2796 } ""] $line null testFile \
2797 Total Passed Skipped Failed]} {
2798 foreach index {Total Passed Skipped Failed} {
2799 incr numTests($index) [set $index]
2802 lappend failFiles $testFile
2804 } elseif {[regexp [join {
2805 {^Number of tests skipped }
2806 {for each constraint:}
2808 } ""] $line match skipped constraint]} {
2809 if {[string match \t* $match]} {
2810 AddToSkippedBecause $constraint $skipped
2813 puts [outputChannel] $line
2818 puts [outputChannel] "Test file error: $msg"
2819 # append the name of the test to a list to be reported
2821 lappend testFileFailures $file
2827 puts [outputChannel] "\nTests ended at [eval $timeCmd]"
2829 if {[info exists testFileFailures]} {
2830 puts [outputChannel] "\nTest files exiting with errors: \n"
2831 foreach file $testFileFailures {
2832 puts [outputChannel] " [file tail $file]\n"
2836 # Checking for subdirectories in which to run tests
2837 foreach directory [GetMatchingDirectories [testsDirectory]] {
2838 set dir [file tail $directory]
2839 puts [outputChannel] [string repeat ~ 44]
2840 puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
2842 uplevel 1 [list ::source [file join $directory all.tcl]]
2844 set endTime [eval $timeCmd]
2845 puts [outputChannel] "\n$dir test ended at $endTime"
2846 puts [outputChannel] ""
2847 puts [outputChannel] [string repeat ~ 44]
2852 #####################################################################
2854 # Test utility procs - not used in tcltest, but may be useful for
2857 # tcltest::loadTestedCommands --
2859 # Uses the specified script to load the commands to test. Allowed to
2860 # be empty, as the tested commands could have been compiled into the
2872 proc tcltest::loadTestedCommands {} {
2874 if {[string equal {} [loadScript]]} {
2878 return [uplevel 1 [loadScript]]
2881 # tcltest::saveState --
2883 # Save information regarding what procs and variables exist.
2889 # Modifies the variable saveState
2894 proc tcltest::saveState {} {
2896 uplevel 1 [list ::set [namespace which -variable saveState]] \
2897 {[::list [::info procs] [::info vars]]}
2898 DebugPuts 2 "[lindex [info level 0] 0]: $saveState"
2902 # tcltest::restoreState --
2904 # Remove procs and variables that didn't exist before the call to
2911 # Removes procs and variables from your environment if they don't
2912 # exist in the saveState variable.
2917 proc tcltest::restoreState {} {
2919 foreach p [uplevel 1 {::info procs}] {
2920 if {([lsearch [lindex $saveState 0] $p] < 0)
2921 && ![string equal [namespace current]::$p \
2922 [uplevel 1 [list ::namespace origin $p]]]} {
2924 DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
2925 uplevel 1 [list ::catch [list ::rename $p {}]]
2928 foreach p [uplevel 1 {::info vars}] {
2929 if {[lsearch [lindex $saveState 1] $p] < 0} {
2930 DebugPuts 2 "[lindex [info level 0] 0]:\
2931 Removing variable $p"
2932 uplevel 1 [list ::catch [list ::unset $p]]
2938 # tcltest::normalizeMsg --
2940 # Removes "extra" newlines from a string.
2943 # msg String to be modified
2946 # string with extra newlines removed
2951 proc tcltest::normalizeMsg {msg} {
2952 regsub "\n$" [string tolower $msg] "" msg
2953 set msg [string map [list "\n\n" "\n"] $msg]
2954 return [string map [list "\n\}" "\}"] $msg]
2957 # tcltest::makeFile --
2959 # Create a new file with the name <name>, and write <contents> to it.
2961 # If this file hasn't been created via makeFile since the last time
2962 # cleanupTests was called, add it to the $filesMade list, so it will be
2963 # removed by the next call to cleanupTests.
2966 # contents content of the new file
2967 # name name of the new file
2968 # directory directory name for new file
2971 # absolute path to the file created
2976 proc tcltest::makeFile {contents name {directory ""}} {
2980 if {[llength [info level 0]] == 3} {
2981 set directory [temporaryDirectory]
2984 set fullName [file join $directory $name]
2986 DebugPuts 3 "[lindex [info level 0] 0]:\
2987 putting ``$contents'' into $fullName"
2989 set fd [open $fullName w]
2990 fconfigure $fd -translation lf
2991 if {[string equal [string index $contents end] \n]} {
2992 puts -nonewline $fd $contents
2998 if {[lsearch -exact $filesMade $fullName] == -1} {
2999 lappend filesMade $fullName
3004 # tcltest::removeFile --
3006 # Removes the named file from the filesystem
3009 # name file to be removed
3010 # directory directory from which to remove file
3013 # return value from [file delete]
3018 proc tcltest::removeFile {name {directory ""}} {
3021 if {[llength [info level 0]] == 2} {
3022 set directory [temporaryDirectory]
3024 set fullName [file join $directory $name]
3025 DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
3026 set idx [lsearch -exact $filesMade $fullName]
3027 set filesMade [lreplace $filesMade $idx $idx]
3030 Warn "removeFile removing \"$fullName\":\n not created by makeFile"
3033 if {![file isfile $fullName]} {
3035 Warn "removeFile removing \"$fullName\":\n not a file"
3038 return [file delete $fullName]
3041 # tcltest::makeDirectory --
3043 # Create a new dir with the name <name>.
3045 # If this dir hasn't been created via makeDirectory since the last time
3046 # cleanupTests was called, add it to the $directoriesMade list, so it
3047 # will be removed by the next call to cleanupTests.
3050 # name name of the new directory
3051 # directory directory in which to create new dir
3054 # absolute path to the directory created
3059 proc tcltest::makeDirectory {name {directory ""}} {
3062 if {[llength [info level 0]] == 2} {
3063 set directory [temporaryDirectory]
3065 set fullName [file join $directory $name]
3066 DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
3067 file mkdir $fullName
3068 if {[lsearch -exact $filesMade $fullName] == -1} {
3069 lappend filesMade $fullName
3074 # tcltest::removeDirectory --
3076 # Removes a named directory from the file system.
3079 # name Name of the directory to remove
3080 # directory Directory from which to remove
3083 # return value from [file delete]
3088 proc tcltest::removeDirectory {name {directory ""}} {
3091 if {[llength [info level 0]] == 2} {
3092 set directory [temporaryDirectory]
3094 set fullName [file join $directory $name]
3095 DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
3096 set idx [lsearch -exact $filesMade $fullName]
3097 set filesMade [lreplace $filesMade $idx $idx]
3100 Warn "removeDirectory removing \"$fullName\":\n not created\
3104 if {![file isdirectory $fullName]} {
3106 Warn "removeDirectory removing \"$fullName\":\n not a directory"
3109 return [file delete -force $fullName]
3112 # tcltest::viewFile --
3114 # reads the content of a file and returns it
3117 # name of the file to read
3118 # directory in which file is located
3121 # content of the named file
3126 proc tcltest::viewFile {name {directory ""}} {
3128 if {[llength [info level 0]] == 2} {
3129 set directory [temporaryDirectory]
3131 set fullName [file join $directory $name]
3132 set f [open $fullName]
3133 set data [read -nonewline $f]
3138 # tcltest::bytestring --
3140 # Construct a string that consists of the requested sequence of bytes,
3141 # as opposed to a string of properly formed UTF-8 characters.
3142 # This allows the tester to
3143 # 1. Create denormalized or improperly formed strings to pass to C
3144 # procedures that are supposed to accept strings with embedded NULL
3146 # 2. Confirm that a string result has a certain pattern of bytes, for
3147 # instance to confirm that "\xe0\0" in a Tcl script is stored
3148 # internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
3150 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
3151 # construct improperly formed strings in this manner, because it involves
3152 # exposing that Tcl uses UTF-8 internally.
3155 # string being converted
3158 # result fom encoding
3163 proc tcltest::bytestring {string} {
3164 return [encoding convertfrom identity $string]
3167 # tcltest::OpenFiles --
3169 # used in io tests, uses testchannel
3180 proc tcltest::OpenFiles {} {
3181 if {[catch {testchannel open} result]} {
3187 # tcltest::LeakFiles --
3189 # used in io tests, uses testchannel
3200 proc tcltest::LeakFiles {old} {
3201 if {[catch {testchannel open} new]} {
3206 if {[lsearch $old $p] < 0} {
3214 # Internationalization / ISO support procs -- dl
3217 # tcltest::SetIso8859_1_Locale --
3219 # used in cmdIL.test, uses testlocale
3230 proc tcltest::SetIso8859_1_Locale {} {
3231 variable previousLocale
3233 if {[info commands testlocale] != ""} {
3234 set previousLocale [testlocale ctype]
3235 testlocale ctype $isoLocale
3240 # tcltest::RestoreLocale --
3242 # used in cmdIL.test, uses testlocale
3253 proc tcltest::RestoreLocale {} {
3254 variable previousLocale
3255 if {[info commands testlocale] != ""} {
3256 testlocale ctype $previousLocale
3261 # tcltest::threadReap --
3263 # Kill all threads except for the main thread.
3264 # Do nothing if testthread is not defined.
3270 # Returns the number of existing threads.
3276 proc tcltest::threadReap {} {
3277 if {[info commands testthread] != {}} {
3279 # testthread built into tcltest
3281 testthread errorproc ThreadNullError
3282 while {[llength [testthread names]] > 1} {
3283 foreach tid [testthread names] {
3284 if {$tid != [mainThread]} {
3286 testthread send -async $tid {testthread exit}
3290 ## Enter a bit a sleep to give the threads enough breathing
3291 ## room to kill themselves off, otherwise the end up with a
3292 ## massive queue of repeated events
3295 testthread errorproc ThreadError
3296 return [llength [testthread names]]
3297 } elseif {[info commands thread::id] != {}} {
3301 thread::errorproc ThreadNullError
3302 while {[llength [thread::names]] > 1} {
3303 foreach tid [thread::names] {
3304 if {$tid != [mainThread]} {
3305 catch {thread::send -async $tid {thread::exit}}
3308 ## Enter a bit a sleep to give the threads enough breathing
3309 ## room to kill themselves off, otherwise the end up with a
3310 ## massive queue of repeated events
3313 thread::errorproc ThreadError
3314 return [llength [thread::names]]
3321 # Initialize the constraints and set up command line arguments
3322 namespace eval tcltest {
3323 # Define initializers for all the built-in contraint definitions
3324 DefineConstraintInitializers
3326 # Set up the constraints in the testConstraints array to be lazily
3327 # initialized by a registered initializer, or by "false" if no
3328 # initializer is registered.
3329 trace variable testConstraints r [namespace code SafeFetch]
3331 # Only initialize constraints at package load time if an
3332 # [initConstraintsHook] has been pre-defined. This is only
3333 # for compatibility support. The modern way to add a custom
3334 # test constraint is to just call the [testConstraint] command
3335 # straight away, without all this "hook" nonsense.
3336 if {[string equal [namespace current] \
3337 [namespace qualifiers [namespace which initConstraintsHook]]]} {
3340 proc initConstraintsHook {} {}
3343 # Define the standard match commands
3344 customMatch exact [list string equal]
3345 customMatch glob [list string match]
3346 customMatch regexp [list regexp --]
3348 # If the TCLTEST_OPTIONS environment variable exists, configure
3349 # tcltest according to the option values it specifies. This has
3350 # the effect of resetting tcltest's default configuration.
3351 proc ConfigureFromEnvironment {} {
3352 upvar #0 env(TCLTEST_OPTIONS) options
3353 if {[catch {llength $options} msg]} {
3354 Warn "invalid TCLTEST_OPTIONS \"$options\":\n invalid\
3358 if {[llength $options] % 2} {
3359 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n should be\
3360 -option value ?-option value ...?"
3363 if {[catch {Configure {*}$options} msg]} {
3364 Warn "invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
3368 if {[info exists ::env(TCLTEST_OPTIONS)]} {
3369 ConfigureFromEnvironment
3372 proc LoadTimeCmdLineArgParsingRequired {} {
3374 if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
3375 # The command line asks for -help, so give it (and exit)
3376 # right now. ([configure] does not process -help)
3379 foreach hook { PrintUsageInfoHook processCmdLineArgsHook
3380 processCmdLineArgsAddFlagsHook } {
3381 if {[string equal [namespace current] [namespace qualifiers \
3382 [namespace which $hook]]]} {
3391 # Only initialize configurable options from the command line arguments
3392 # at package load time if necessary for backward compatibility. This
3393 # lets the tcltest user call [configure] for themselves if they wish.
3394 # Traces are established for auto-configuration from the command line
3395 # if any configurable options are accessed before the user calls
3397 if {[LoadTimeCmdLineArgParsingRequired]} {
3400 EstablishAutoConfigureTraces
3403 package provide [namespace tail [namespace current]] $Version