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.
21 package require
Tcl 8.5 ;# To provide an alpha version
22 package require
Tcl 8.3 ;# uses [glob -directory]
23 namespace eval tcltest {
25 # When the version number changes, be sure to update the pkgIndex.tcl file,
26 # and the install directory in the Makefiles. When the minor version
27 # changes (new feature) be sure to update the man page as well.
28 variable Version
2.3a1
30 # Compatibility support for dumb variables defined in tcltest 1
31 # Do not use these. Call [package provide Tcl] and [info patchlevel]
32 # yourself. You don't need tcltest to wrap it for you.
33 variable version
[package provide
Tcl]
34 variable patchLevel
[info patchlevel
]
36 ##### Export the public tcltest procs; several categories
38 # Export the main functional commands that do useful things
39 namespace export cleanupTests loadTestedCommands makeDirectory
\
40 makeFile removeDirectory removeFile runAllTests test
42 # Export configuration commands that control the functional commands
43 namespace export configure customMatch errorChannel interpreter
\
44 outputChannel testConstraint
46 # Export commands that are duplication (candidates for deprecation)
47 namespace export bytestring
;# dups [encoding convertfrom identity]
48 namespace export debug
;# [configure -debug]
49 namespace export errorFile
;# [configure -errfile]
50 namespace export limitConstraints
;# [configure -limitconstraints]
51 namespace export loadFile
;# [configure -loadfile]
52 namespace export loadScript
;# [configure -load]
53 namespace export match
;# [configure -match]
54 namespace export matchFiles
;# [configure -file]
55 namespace export matchDirectories
;# [configure -relateddir]
56 namespace export normalizeMsg
;# application of [customMatch]
57 namespace export normalizePath
;# [file normalize] (8.4)
58 namespace export outputFile
;# [configure -outfile]
59 namespace export preserveCore
;# [configure -preservecore]
60 namespace export singleProcess
;# [configure -singleproc]
61 namespace export skip
;# [configure -skip]
62 namespace export skipFiles
;# [configure -notfile]
63 namespace export skipDirectories
;# [configure -asidefromdir]
64 namespace export temporaryDirectory
;# [configure -tmpdir]
65 namespace export testsDirectory
;# [configure -testdir]
66 namespace export verbose
;# [configure -verbose]
67 namespace export viewFile
;# binary encoding [read]
68 namespace export workingDirectory
;# [cd] [pwd]
70 # Export deprecated commands for tcltest 1 compatibility
71 namespace export getMatchingFiles mainThread restoreState saveState
\
74 # tcltest::normalizePath --
76 # This procedure resolves any symlinks in the path thus creating
77 # a path without internal redirection. It assumes that the
78 # incoming path is absolute.
81 # pathVar - name of variable containing path to modify.
84 # The path is modified in place.
89 proc normalizePath
{pathVar
} {
98 ##### Verification commands used to test values of variables and options
100 # Verification command that accepts everything
101 proc AcceptAll
{value
} {
105 # Verification command that accepts valid Tcl lists
106 proc AcceptList
{ list } {
107 return [lrange $list 0 end
]
110 # Verification command that accepts a glob pattern
111 proc AcceptPattern
{ pattern
} {
112 return [AcceptAll
$pattern]
115 # Verification command that accepts integers
116 proc AcceptInteger
{ level
} {
117 return [incr level
0]
120 # Verification command that accepts boolean values
121 proc AcceptBoolean
{ boolean
} {
122 return [expr {$boolean && $boolean}]
125 # Verification command that accepts (syntactically) valid Tcl scripts
126 proc AcceptScript
{ script
} {
127 if {![info complete
$script]} {
128 return -code error "invalid Tcl script: $script"
133 # Verification command that accepts (converts to) absolute pathnames
134 proc AcceptAbsolutePath
{ path
} {
135 return [file join [pwd] $path]
138 # Verification command that accepts existing readable directories
139 proc AcceptReadable
{ path
} {
140 if {![file readable
$path]} {
141 return -code error "\"$path\" is not readable"
145 proc AcceptDirectory
{ directory
} {
146 set directory
[AcceptAbsolutePath
$directory]
147 if {![file exists
$directory]} {
148 return -code error "\"$directory\" does not exist"
150 if {![file isdir
$directory]} {
151 return -code error "\"$directory\" is not a directory"
153 return [AcceptReadable
$directory]
156 ##### Initialize internal arrays of tcltest, but only if the caller
157 # has not already pre-initialized them. This is done to support
158 # compatibility with older tests that directly access internals
159 # rather than go through command interfaces.
161 proc ArrayDefault
{varName value
} {
163 if {[array exists
$varName]} {
166 if {[info exists
$varName]} {
167 # Pre-initialized value is a scalar: destroy it!
170 array set $varName $value
173 # save the original environment so that it can be restored later
174 ArrayDefault originalEnv
[array get
::env]
176 # initialize numTests array to keep track of the number of tests
177 # that pass, fail, and are skipped.
178 ArrayDefault numTests
[list Total
0 Passed
0 Skipped
0 Failed
0]
180 # createdNewFiles will store test files as indices and the list of
181 # files (that should not have been) left behind by the test files
183 ArrayDefault createdNewFiles
{}
185 # initialize skippedBecause array to keep track of constraints that
186 # kept tests from running; a constraint name of "userSpecifiedSkip"
187 # means that the test appeared on the list of tests that matched the
188 # -skip value given to the flag; "userSpecifiedNonMatch" means that
189 # the test didn't match the argument given to the -match flag; both
190 # of these constraints are counted only if tcltest::debug is set to
192 ArrayDefault skippedBecause
{}
194 # initialize the testConstraints array to keep track of valid
195 # predefined constraints (see the explanation for the
196 # InitConstraints proc for more details).
197 ArrayDefault testConstraints
{}
199 ##### Initialize internal variables of tcltest, but only if the caller
200 # has not already pre-initialized them. This is done to support
201 # compatibility with older tests that directly access internals
202 # rather than go through command interfaces.
204 proc Default
{varName value
{verify AcceptAll
}} {
206 if {![info exists
$varName]} {
207 variable $varName [$verify $value]
209 variable $varName [$verify [set $varName]]
213 # Save any arguments that we might want to pass through to other
214 # programs. This is used by the -args flag.
216 Default parameters
{}
218 # Count the number of files tested (0 if runAllTests wasn't called).
219 # runAllTests will set testSingleFile to false, so stats will
220 # not be printed until runAllTests calls the cleanupTests proc.
221 # The currentFailure var stores the boolean value of whether the
222 # current test file has had any failures. The failFiles list
223 # stores the names of test files that had failures.
224 Default numTestFiles
0 AcceptInteger
225 Default testSingleFile true AcceptBoolean
226 Default currentFailure false AcceptBoolean
227 Default failFiles
{} AcceptList
229 # Tests should remove all files they create. The test suite will
230 # check the current working dir for files created by the tests.
231 # filesMade keeps track of such files created using the makeFile and
232 # makeDirectory procedures. filesExisted stores the names of
233 # pre-existing files.
235 # Note that $filesExisted lists only those files that exist in
236 # the original [temporaryDirectory].
237 Default filesMade
{} AcceptList
238 Default filesExisted
{} AcceptList
239 proc FillFilesExisted
{} {
240 variable filesExisted
242 # Save the names of files that already exist in the scratch directory.
243 foreach file [glob -nocomplain -directory [temporaryDirectory
] *] {
244 lappend filesExisted
[file tail
$file]
247 # After successful filling, turn this into a no-op.
248 proc FillFilesExisted args
{}
251 # Kept only for compatibility
252 Default constraintsSpecified
{} AcceptList
253 trace variable constraintsSpecified r
{set ::tcltest::constraintsSpecified \
254 [array names
::tcltest::testConstraints] ;# }
256 # tests that use threads need to know which is the main thread
259 if {[info commands thread
::id] != {}} {
260 set mainThread
[thread
::id]
261 } elseif
{[info commands testthread
] != {}} {
262 set mainThread
[testthread id
]
265 # Set workingDirectory to [pwd]. The default output directory for
266 # Tcl tests is the working directory. Whenever this value changes
267 # change to that directory.
268 variable workingDirectory
269 trace variable workingDirectory w
\
270 [namespace code
{cd $workingDirectory ;#}]
272 Default workingDirectory
[pwd] AcceptAbsolutePath
273 proc workingDirectory
{ {dir
""} } {
274 variable workingDirectory
275 if {[llength [info level
0]] == 1} {
276 return $workingDirectory
278 set workingDirectory
[AcceptAbsolutePath
$dir]
281 # Set the location of the execuatble
282 Default
tcltest [info nameofexecutable
]
283 trace variable tcltest w
[namespace code
{testConstraint stdio
\
284 [eval [ConstraintInitializer stdio
]] ;#}]
286 # save the platform information so it can be restored later
287 Default originalTclPlatform
[array get
::tcl_platform]
289 # If a core file exists, save its modification time.
290 if {[file exists
[file join [workingDirectory
] core
]]} {
291 Default coreModTime
\
292 [file mtime
[file join [workingDirectory
] core
]]
295 # stdout and stderr buffers for use when we want to store them
299 # keep track of test level for nested test commands
302 # the variables and procs that existed when saveState was called are
303 # stored in a variable of the same name
306 # Internationalization support -- used in [SetIso8859_1_Locale] and
307 # [RestoreLocale]. Those commands are used in cmdIL.test.
309 if {![info exists
[namespace current
]::isoLocale]} {
310 variable isoLocale fr
311 switch -- $::tcl_platform(platform
) {
314 # Try some 'known' values for some platforms:
316 switch -exact -- $::tcl_platform(os
) {
318 set isoLocale fr_FR.ISO_8859-1
321 set isoLocale fr_FR.iso88591
329 # Works on SunOS 4 and Solaris, and maybe
330 # others... Define it to something else on your
331 # system if you want to test those.
333 set isoLocale iso_8859_1
343 variable ChannelsWeOpened
; array set ChannelsWeOpened
{}
344 # output goes to stdout by default
345 Default outputChannel stdout
346 proc outputChannel
{ {filename ""} } {
347 variable outputChannel
348 variable ChannelsWeOpened
350 # This is very subtle and tricky, so let me try to explain.
351 # (Hopefully this longer comment will be clear when I come
352 # back in a few months, unlike its predecessor :) )
354 # The [outputChannel] command (and underlying variable) have to
355 # be kept in sync with the [configure -outfile] configuration
356 # option ( and underlying variable Option(-outfile) ). This is
357 # accomplished with a write trace on Option(-outfile) that will
358 # update [outputChannel] whenver a new value is written. That
361 # The trick is that in order to maintain compatibility with
362 # version 1 of tcltest, we must allow every configuration option
363 # to get its inital value from command line arguments. This is
364 # accomplished by setting initial read traces on all the
365 # configuration options to parse the command line option the first
366 # time they are read. These traces are cancelled whenever the
367 # program itself calls [configure].
369 # OK, then so to support tcltest 1 compatibility, it seems we want
370 # to get the return from [outputFile] to trigger the read traces,
373 # BUT! A little known feature of Tcl variable traces is that
374 # traces are disabled during the handling of other traces. So,
375 # if we trigger read traces on Option(-outfile) and that triggers
376 # command line parsing which turns around and sets an initial
377 # value for Option(-outfile) -- <whew!> -- the write trace that
378 # would keep [outputChannel] in sync with that new initial value
381 # SO, finally, as a workaround, instead of triggering read traces
382 # by invoking [outputFile], we instead trigger the same set of
383 # read traces by invoking [debug]. Any command that reads a
384 # configuration option would do. [debug] is just a handy one.
385 # The end result is that we support tcltest 1 compatibility and
386 # keep outputChannel and -outfile in sync in all cases.
389 if {[llength [info level
0]] == 1} {
390 return $outputChannel
392 if {[info exists ChannelsWeOpened
($outputChannel)]} {
394 unset ChannelsWeOpened
($outputChannel)
396 switch -exact -- $filename {
399 set outputChannel
$filename
402 set outputChannel
[open $filename a
]
403 set ChannelsWeOpened
($outputChannel) 1
405 # If we created the file in [temporaryDirectory], then
406 # [cleanupTests] will delete it, unless we claim it was
408 set outdir
[normalizePath
[file dirname
\
409 [file join [pwd] $filename]]]
410 if {[string equal
$outdir [temporaryDirectory
]]} {
411 variable filesExisted
413 set filename [file tail
$filename]
414 if {[lsearch -exact $filesExisted $filename] == -1} {
415 lappend filesExisted
$filename
420 return $outputChannel
423 # errors go to stderr by default
424 Default errorChannel stderr
425 proc errorChannel
{ {filename ""} } {
426 variable errorChannel
427 variable ChannelsWeOpened
429 # This is subtle and tricky. See the comment above in
430 # [outputChannel] for a detailed explanation.
433 if {[llength [info level
0]] == 1} {
436 if {[info exists ChannelsWeOpened
($errorChannel)]} {
438 unset ChannelsWeOpened
($errorChannel)
440 switch -exact -- $filename {
443 set errorChannel
$filename
446 set errorChannel
[open $filename a
]
447 set ChannelsWeOpened
($errorChannel) 1
449 # If we created the file in [temporaryDirectory], then
450 # [cleanupTests] will delete it, unless we claim it was
452 set outdir
[normalizePath
[file dirname
\
453 [file join [pwd] $filename]]]
454 if {[string equal
$outdir [temporaryDirectory
]]} {
455 variable filesExisted
457 set filename [file tail
$filename]
458 if {[lsearch -exact $filesExisted $filename] == -1} {
459 lappend filesExisted
$filename
467 ##### Set up the configurable options
469 # The configurable options of the package
470 variable Option
; array set Option
{}
472 # Usage strings for those options
473 variable Usage
; array set Usage
{}
475 # Verification commands for those options
476 variable Verify
; array set Verify
{}
478 # Initialize the default values of the configurable options that are
479 # historically associated with an exported variable. If that variable
480 # is already set, support compatibility by accepting its pre-set value.
481 # Use [trace] to establish ongoing connection between the deprecated
482 # exported variable and the modern option kept as a true internal var.
483 # Also set up usage string and value testing for the option.
484 proc Option
{option value usage
{verify AcceptAll
} {varName
{}}} {
488 variable OptionControlledVariables
489 set Usage
($option) $usage
490 set Verify
($option) $verify
491 if {[catch {$verify $value} msg
]} {
492 return -code error $msg
494 set Option
($option) $msg
496 if {[string length
$varName]} {
498 if {[info exists
$varName]} {
499 if {[catch {$verify [set $varName]} msg
]} {
500 return -code error $msg
502 set Option
($option) $msg
506 namespace eval [namespace current
] \
507 [list upvar 0 Option
($option) $varName]
508 # Workaround for Bug (now Feature Request) 572889. Grrrr....
509 # Track all the variables tied to options
510 lappend OptionControlledVariables
$varName
511 # Later, set auto-configure read traces on all
512 # of them, since a single trace on Option does not work.
513 proc $varName {{value
{}}} [subst -nocommands {
514 if {[llength [info level
0]] == 2} {
515 Configure
$option [set value
]
517 return [Configure
$option]
522 proc MatchingOption
{option} {
524 set match
[array names Option
$option*]
525 switch -- [llength $match] {
527 set sorted
[lsort [array names Option
]]
528 set values
[join [lrange $sorted 0 end-1
] ", "]
529 append values
", or [lindex $sorted end]"
530 return -code error "unknown option $option: should be\
534 return [lindex $match 0]
537 # Exact match trumps ambiguity
538 if {[lsearch -exact $match $option] >= 0} {
541 set values
[join [lrange $match 0 end-1
] ", "]
542 append values
", or [lindex $match end]"
543 return -code error "ambiguous option $option:\
549 proc EstablishAutoConfigureTraces
{} {
550 variable OptionControlledVariables
551 foreach varName
[concat $OptionControlledVariables Option
] {
553 trace variable $varName r
[namespace code
{ProcessCmdLineArgs
;#}]
557 proc RemoveAutoConfigureTraces
{} {
558 variable OptionControlledVariables
559 foreach varName
[concat $OptionControlledVariables Option
] {
561 foreach pair
[trace vinfo
$varName] {
562 foreach {op cmd
} $pair break
563 if {[string equal r
$op]
564 && [string match
*ProcessCmdLineArgs
* $cmd]} {
565 trace vdelete
$varName $op $cmd
569 # Once the traces are removed, this can become a no-op
570 proc RemoveAutoConfigureTraces
{} {}
573 proc Configure args
{
576 set n
[llength $args]
578 return [lsort [array names Option
]]
581 if {[catch {MatchingOption
[lindex $args 0]} option]} {
582 return -code error $option
584 return $Option($option)
586 while {[llength $args] > 1} {
587 if {[catch {MatchingOption
[lindex $args 0]} option]} {
588 return -code error $option
590 if {[catch {$Verify($option) [lindex $args 1]} value
]} {
591 return -code error "invalid $option\
592 value \"[lindex $args 1]\": $value"
594 set Option
($option) $value
595 set args
[lrange $args 2 end
]
597 if {[llength $args]} {
598 if {[catch {MatchingOption
[lindex $args 0]} option]} {
599 return -code error $option
601 return -code error "missing value for option $option"
604 proc configure args
{
605 RemoveAutoConfigureTraces
606 set code
[catch {eval Configure
$args} msg
]
607 return -code $code $msg
610 proc AcceptVerbose
{ level
} {
611 set level
[AcceptList
$level]
612 if {[llength $level] == 1} {
613 if {![regexp {^
(pass|body|skip|start|
error|line
)$} $level]} {
614 # translate single characters abbreviations to expanded list
615 set level
[string map
{p pass b body s skip t start e
error l line
} \
621 if {[regexp {^
(pass|body|skip|start|
error|line
)$} $v]} {
628 proc IsVerbose
{level
} {
630 return [expr {[lsearch -exact $Option(-verbose) $level] != -1}]
633 # Default verbosity is to show bodies of failed tests
634 Option
-verbose {body
error} {
635 Takes any combination of the values 'p'
, 's'
, 'b'
, 't'
, 'e' and 'l'.
636 Test suite will display all passed tests
if 'p' is specified
, all
637 skipped tests
if 's' is specified
, the bodies of failed tests
if
638 'b' is specified
, and when tests start
if 't' is specified.
639 ErrorInfo is displayed
if 'e' is specified. Source
file line
640 information of failed tests is displayed
if 'l' is specified.
641 } AcceptVerbose verbose
643 # Match and skip patterns default to the empty list, except for
644 # matchFiles, which defaults to all .test files in the
645 # testsDirectory and matchDirectories, which defaults to all
648 Run all tests within the specified files that match one of the
649 list of
glob patterns given.
653 Skip all tests within the specified tests
(via
-match) and files
654 that match one of the
list of
glob patterns given.
657 Option
-file *.test
{
658 Run tests in all test files that match the
glob pattern given.
659 } AcceptPattern matchFiles
661 # By default, skip files that appear to be SCCS lock files.
662 Option
-notfile l.
*.test
{
663 Skip all test files that match the
glob pattern given.
664 } AcceptPattern skipFiles
666 Option
-relateddir * {
667 Run tests in directories that match the
glob pattern given.
668 } AcceptPattern matchDirectories
670 Option
-asidefromdir {} {
671 Skip tests in directories that match the
glob pattern given.
672 } AcceptPattern skipDirectories
674 # By default, don't save core files
675 Option
-preservecore 0 {
676 If
2, save any core files produced during testing in the directory
677 specified by
-tmpdir. If
1, notify the user
if core files are
679 } AcceptInteger preserveCore
681 # debug output doesn't get printed by default; debug level 1 spits
682 # up only the tests that were skipped because they didn't match or
683 # were specifically skipped. A debug level of 2 would spit up the
684 # tcltest variables and flags provided; a debug level of 3 causes
685 # some additional output regarding operations of the test harness.
686 # The tcltest package currently implements only up to debug level 3.
689 } AcceptInteger debug
691 proc SetSelectedConstraints args
{
693 foreach c
$Option(-constraints) {
697 Option
-constraints {} {
698 Do not skip the listed constraints listed in
-constraints.
700 trace variable Option
(-constraints) w
\
701 [namespace code
{SetSelectedConstraints
;#}]
703 # Don't run only the "-constraint" specified tests by default
704 proc ClearUnselectedConstraints args
{
706 variable testConstraints
707 if {!$Option(-limitconstraints)} {return}
708 foreach c
[array names testConstraints
] {
709 if {[lsearch -exact $Option(-constraints) $c] == -1} {
714 Option
-limitconstraints false
{
715 whether to run only tests with the constraints
716 } AcceptBoolean limitConstraints
717 trace variable Option
(-limitconstraints) w
\
718 [namespace code
{ClearUnselectedConstraints
;#}]
720 # A test application has to know how to load the tested commands
721 # into the interpreter.
723 Specifies the script to
load the tested commands.
724 } AcceptScript loadScript
726 # Default is to run each test file in a separate process
727 Option
-singleproc 0 {
728 whether to run all tests in one process
729 } AcceptBoolean singleProcess
731 proc AcceptTemporaryDirectory
{ directory
} {
732 set directory
[AcceptAbsolutePath
$directory]
733 if {![file exists
$directory]} {
734 file mkdir
$directory
736 set directory
[AcceptDirectory
$directory]
737 if {![file writable
$directory]} {
738 if {[string equal
[workingDirectory
] $directory]} {
739 # Special exception: accept the default value
740 # even if the directory is not writable
743 return -code error "\"$directory\" is not writeable"
748 # Directory where files should be created
749 Option
-tmpdir [workingDirectory
] {
750 Save temporary files in the specified directory.
751 } AcceptTemporaryDirectory temporaryDirectory
752 trace variable Option
(-tmpdir) w
\
753 [namespace code
{normalizePath Option
(-tmpdir) ;#}]
755 # Tests should not rely on the current working directory.
756 # Files that are part of the test suite should be accessed relative
757 # to [testsDirectory]
758 Option
-testdir [workingDirectory
] {
759 Search tests in the specified directory.
760 } AcceptDirectory testsDirectory
761 trace variable Option
(-testdir) w
\
762 [namespace code
{normalizePath Option
(-testdir) ;#}]
764 proc AcceptLoadFile
{ file } {
765 if {[string equal
"" $file]} {return $file}
766 set file [file join [temporaryDirectory
] $file]
767 return [AcceptReadable
$file]
769 proc ReadLoadScript
{args
} {
771 if {[string equal
"" $Option(-loadfile)]} {return}
772 set tmp
[open $Option(-loadfile) r
]
773 loadScript
[read $tmp]
776 Option
-loadfile {} {
777 Read the script to
load the tested commands from the specified
file.
778 } AcceptLoadFile loadFile
779 trace variable Option
(-loadfile) w
[namespace code ReadLoadScript
]
781 proc AcceptOutFile
{ file } {
782 if {[string equal stderr
$file]} {return $file}
783 if {[string equal stdout
$file]} {return $file}
784 return [file join [temporaryDirectory
] $file]
787 # output goes to stdout by default
788 Option
-outfile stdout
{
789 Send output from test runs to the specified
file.
790 } AcceptOutFile outputFile
791 trace variable Option
(-outfile) w
\
792 [namespace code
{outputChannel
$Option(-outfile) ;#}]
794 # errors go to stderr by default
795 Option
-errfile stderr
{
796 Send errors from test runs to the specified
file.
797 } AcceptOutFile errorFile
798 trace variable Option
(-errfile) w
\
799 [namespace code
{errorChannel
$Option(-errfile) ;#}]
803 #####################################################################
807 # Internal helper procedures to write out debug information
808 # dependent on the chosen level. A test shell may overide
809 # them, f.e. to redirect the output into a different
810 # channel, or even into a GUI.
812 # tcltest::DebugPuts --
814 # Prints the specified string if the current debug level is
815 # higher than the provided level argument.
818 # level The lowest debug level triggering the output
819 # string The string to print out.
822 # Prints the string. Nothing else is allowed.
828 proc tcltest::DebugPuts {level
string} {
830 if {$debug >= $level} {
836 # tcltest::DebugPArray --
838 # Prints the contents of the specified array if the current
839 # debug level is higher than the provided level argument
842 # level The lowest debug level triggering the output
843 # arrayvar The name of the array to print out.
846 # Prints the contents of the array. Nothing else is allowed.
852 proc tcltest::DebugPArray {level arrayvar
} {
855 if {$debug >= $level} {
856 catch {upvar $arrayvar $arrayvar}
862 # Define our own [parray] in ::tcltest that will inherit use of the [puts]
863 # defined in ::tcltest. NOTE: Ought to construct with [info args] and
864 # [info default], but can't be bothered now. If [parray] changes, then
865 # this will need changing too.
867 proc tcltest::parray {a
{pattern
*}} [info body
::parray]
869 # tcltest::DebugDo --
871 # Executes the script if the current debug level is greater than
872 # the provided level argument
875 # level The lowest debug level triggering the execution.
876 # script The tcl script executed upon a debug level high enough.
879 # Arbitrary side effects, dependent on the executed script.
885 proc tcltest::DebugDo {level script
} {
888 if {$debug >= $level} {
894 #####################################################################
896 proc tcltest::Warn {msg
} {
897 puts [outputChannel
] "WARNING: $msg"
900 # tcltest::mainThread
902 # Accessor command for tcltest variable mainThread.
904 proc tcltest::mainThread { {new
""} } {
906 if {[llength [info level
0]] == 1} {
912 # tcltest::testConstraint --
914 # sets a test constraint to a value; to do multiple constraints,
915 # call this proc multiple times. also returns the value of the
916 # named constraint if no value was supplied.
919 # constraint - name of the constraint
920 # value - new value for constraint (should be boolean) - if not
921 # supplied, this is a query
924 # content of tcltest::testConstraints($constraint)
929 proc tcltest::testConstraint {constraint
{value
""}} {
930 variable testConstraints
932 DebugPuts
3 "entering testConstraint $constraint $value"
933 if {[llength [info level
0]] == 2} {
934 return $testConstraints($constraint)
936 # Check for boolean values
937 if {[catch {expr {$value && $value}} msg
]} {
938 return -code error $msg
940 if {[limitConstraints
]
941 && [lsearch -exact $Option(-constraints) $constraint] == -1} {
944 set testConstraints
($constraint) $value
947 # tcltest::interpreter --
949 # the interpreter name stored in tcltest::tcltest
955 # content of tcltest::tcltest
960 proc tcltest::interpreter { {interp ""} } {
962 if {[llength [info level
0]] == 1} {
965 if {[string equal
{} $interp]} {
972 #####################################################################
974 # tcltest::AddToSkippedBecause --
976 # Increments the variable used to track how many tests were
977 # skipped because of a particular constraint.
980 # constraint The name of the constraint to be modified
983 # Modifies tcltest::skippedBecause; sets the variable to 1 if
984 # didn't previously exist - otherwise, it just increments it.
989 proc tcltest::AddToSkippedBecause { constraint
{value
1}} {
990 # add the constraint to the list of constraints that kept tests
992 variable skippedBecause
994 if {[info exists skippedBecause
($constraint)]} {
995 incr skippedBecause
($constraint) $value
997 set skippedBecause
($constraint) $value
1002 # tcltest::PrintError --
1004 # Prints errors to tcltest::errorChannel and then flushes that
1005 # channel, making sure that all messages are < 80 characters per
1009 # errorMsg String containing the error to be printed
1017 proc tcltest::PrintError {errorMsg
} {
1018 set InitialMessage
"Error: "
1019 set InitialMsgLen
[string length
$InitialMessage]
1020 puts -nonewline [errorChannel
] $InitialMessage
1022 # Keep track of where the end of the string is.
1023 set endingIndex
[string length
$errorMsg]
1025 if {$endingIndex < (80 - $InitialMsgLen)} {
1026 puts [errorChannel
] $errorMsg
1028 # Print up to 80 characters on the first line, including the
1030 set beginningIndex
[string last
" " [string range
$errorMsg 0 \
1031 [expr {80 - $InitialMsgLen}]]]
1032 puts [errorChannel
] [string range
$errorMsg 0 $beginningIndex]
1034 while {![string equal end
$beginningIndex]} {
1035 puts -nonewline [errorChannel
] \
1036 [string repeat
" " $InitialMsgLen]
1037 if {($endingIndex - $beginningIndex)
1038 < (80 - $InitialMsgLen)} {
1039 puts [errorChannel
] [string trim
\
1040 [string range
$errorMsg $beginningIndex end
]]
1043 set newEndingIndex
[expr {[string last
" " \
1044 [string range
$errorMsg $beginningIndex \
1045 [expr {$beginningIndex
1046 + (80 - $InitialMsgLen)}]
1047 ]] + $beginningIndex}]
1048 if {($newEndingIndex <= 0)
1049 ||
($newEndingIndex <= $beginningIndex)} {
1050 set newEndingIndex end
1052 puts [errorChannel
] [string trim
\
1053 [string range
$errorMsg \
1054 $beginningIndex $newEndingIndex]]
1055 set beginningIndex
$newEndingIndex
1059 flush [errorChannel
]
1063 # tcltest::SafeFetch --
1065 # The following trace procedure makes it so that we can safely
1066 # refer to non-existent members of the testConstraints array
1067 # without causing an error. Instead, reading a non-existent
1068 # member will return 0. This is necessary because tests are
1069 # allowed to use constraint "X" without ensuring that
1070 # testConstraints("X") is defined.
1073 # n1 - name of the array (testConstraints)
1074 # n2 - array key value (constraint name)
1075 # op - operation performed on testConstraints (generally r)
1081 # sets testConstraints($n2) to 0 if it's referenced but never
1084 proc tcltest::SafeFetch {n1 n2 op
} {
1085 variable testConstraints
1086 DebugPuts
3 "entering SafeFetch $n1 $n2 $op"
1087 if {[string equal
{} $n2]} {return}
1088 if {![info exists testConstraints
($n2)]} {
1089 if {[catch {testConstraint
$n2 [eval [ConstraintInitializer
$n2]]}]} {
1090 testConstraint
$n2 0
1095 # tcltest::ConstraintInitializer --
1097 # Get or set a script that when evaluated in the tcltest namespace
1098 # will return a boolean value with which to initialize the
1099 # associated constraint.
1102 # constraint - name of the constraint initialized by the script
1103 # script - the initializer script
1106 # boolean value of the constraint - enabled or disabled
1109 # Constraint is initialized for future reference by [test]
1110 proc tcltest::ConstraintInitializer {constraint
{script
""}} {
1111 variable ConstraintInitializer
1112 DebugPuts
3 "entering ConstraintInitializer $constraint $script"
1113 if {[llength [info level
0]] == 2} {
1114 return $ConstraintInitializer($constraint)
1116 # Check for boolean values
1117 if {![info complete
$script]} {
1118 return -code error "ConstraintInitializer must be complete script"
1120 set ConstraintInitializer
($constraint) $script
1123 # tcltest::InitConstraints --
1125 # Call all registered constraint initializers to force initialization
1126 # of all known constraints.
1127 # See the tcltest man page for the list of built-in constraints defined
1128 # in this procedure.
1134 # The testConstraints array is reset to have an index for each
1135 # built-in test constraint.
1141 proc tcltest::InitConstraints {} {
1142 variable ConstraintInitializer
1144 foreach constraint
[array names ConstraintInitializer
] {
1145 testConstraint
$constraint
1149 proc tcltest::DefineConstraintInitializers {} {
1150 ConstraintInitializer singleTestInterp
{singleProcess
}
1152 # All the 'pc' constraints are here for backward compatibility and
1153 # are not documented. They have been replaced with equivalent 'win'
1156 ConstraintInitializer unixOnly
\
1157 {string equal
$::tcl_platform(platform
) unix
}
1158 ConstraintInitializer macOnly
\
1159 {string equal
$::tcl_platform(platform
) macintosh
}
1160 ConstraintInitializer pcOnly
\
1161 {string equal
$::tcl_platform(platform
) windows
}
1162 ConstraintInitializer winOnly
\
1163 {string equal
$::tcl_platform(platform
) windows
}
1165 ConstraintInitializer unix
{testConstraint unixOnly
}
1166 ConstraintInitializer mac
{testConstraint macOnly
}
1167 ConstraintInitializer pc
{testConstraint pcOnly
}
1168 ConstraintInitializer win
{testConstraint winOnly
}
1170 ConstraintInitializer unixOrPc
\
1171 {expr {[testConstraint unix
] ||
[testConstraint pc
]}}
1172 ConstraintInitializer macOrPc
\
1173 {expr {[testConstraint mac
] ||
[testConstraint pc
]}}
1174 ConstraintInitializer unixOrWin
\
1175 {expr {[testConstraint unix
] ||
[testConstraint win
]}}
1176 ConstraintInitializer macOrWin
\
1177 {expr {[testConstraint mac
] ||
[testConstraint win
]}}
1178 ConstraintInitializer macOrUnix
\
1179 {expr {[testConstraint mac
] ||
[testConstraint unix
]}}
1181 ConstraintInitializer nt
{string equal
$::tcl_platform(os
) "Windows NT"}
1182 ConstraintInitializer
95 {string equal
$::tcl_platform(os
) "Windows 95"}
1183 ConstraintInitializer
98 {string equal
$::tcl_platform(os
) "Windows 98"}
1185 # The following Constraints switches are used to mark tests that
1186 # should work, but have been temporarily disabled on certain
1187 # platforms because they don't and we haven't gotten around to
1188 # fixing the underlying problem.
1190 ConstraintInitializer tempNotPc
{expr {![testConstraint pc
]}}
1191 ConstraintInitializer tempNotWin
{expr {![testConstraint win
]}}
1192 ConstraintInitializer tempNotMac
{expr {![testConstraint mac
]}}
1193 ConstraintInitializer tempNotUnix
{expr {![testConstraint unix
]}}
1195 # The following Constraints switches are used to mark tests that
1196 # crash on certain platforms, so that they can be reactivated again
1197 # when the underlying problem is fixed.
1199 ConstraintInitializer pcCrash
{expr {![testConstraint pc
]}}
1200 ConstraintInitializer winCrash
{expr {![testConstraint win
]}}
1201 ConstraintInitializer macCrash
{expr {![testConstraint mac
]}}
1202 ConstraintInitializer unixCrash
{expr {![testConstraint unix
]}}
1206 ConstraintInitializer emptyTest
{format 0}
1208 # By default, tests that expose known bugs are skipped.
1210 ConstraintInitializer knownBug
{format 0}
1212 # By default, non-portable tests are skipped.
1214 ConstraintInitializer nonPortable
{format 0}
1216 # Some tests require user interaction.
1218 ConstraintInitializer userInteraction
{format 0}
1220 # Some tests must be skipped if the interpreter is not in
1223 ConstraintInitializer interactive
\
1224 {expr {[info exists
::tcl_interactive] && $::tcl_interactive}}
1226 # Some tests can only be run if the installation came from a CD
1227 # image instead of a web image. Some tests must be skipped if you
1228 # are running as root on Unix. Other tests can only be run if you
1229 # are running as root on Unix.
1231 ConstraintInitializer root
{expr \
1232 {[string equal unix
$::tcl_platform(platform
)]
1233 && ([string equal root
$::tcl_platform(user
)]
1234 ||
[string equal
"" $::tcl_platform(user
)])}}
1235 ConstraintInitializer notRoot
{expr {![testConstraint root
]}}
1237 # Set nonBlockFiles constraint: 1 means this platform supports
1238 # setting files into nonblocking mode.
1240 ConstraintInitializer nonBlockFiles
{
1241 set code
[expr {[catch {set f
[open defs r
]}]
1242 ||
[catch {fconfigure $f -blocking off
}]}]
1247 # Set asyncPipeClose constraint: 1 means this platform supports
1248 # async flush and async close on a pipe.
1250 # Test for SCO Unix - cannot run async flushing tests because a
1251 # potential problem with select is apparently interfering.
1254 ConstraintInitializer asyncPipeClose
{expr {
1255 !([string equal unix
$::tcl_platform(platform
)]
1256 && ([catch {exec uname
-X | fgrep
{Release
= 3.2v
}}] == 0))}}
1258 # Test to see if we have a broken version of sprintf with respect
1259 # to the "e" format of floating-point numbers.
1261 ConstraintInitializer eformat
{string equal
[format %g
5e-5] 5e-05}
1263 # Test to see if execed commands such as cat, echo, rm and so forth
1264 # are present on this machine.
1266 ConstraintInitializer unixExecs
{
1268 if {[string equal macintosh
$::tcl_platform(platform
)]} {
1271 if {[string equal windows
$::tcl_platform(platform
)]} {
1273 set file _tcl_test_remove_me.txt
1274 makeFile
{hello
} $file
1278 [catch {exec cat
$file}] ||
1279 [catch {exec echo hello
}] ||
1280 [catch {exec sh
-c echo hello
}] ||
1281 [catch {exec wc
$file}] ||
1282 [catch {exec sleep
1}] ||
1283 [catch {exec echo abc
> $file}] ||
1284 [catch {exec chmod
644 $file}] ||
1285 [catch {exec rm
$file}] ||
1286 [llength [auto_execok mkdir
]] == 0 ||
1287 [llength [auto_execok fgrep
]] == 0 ||
1288 [llength [auto_execok grep
]] == 0 ||
1289 [llength [auto_execok ps
]] == 0
1298 ConstraintInitializer stdio
{
1300 if {![catch {set f
[open "|[list [interpreter]]" w
]}]} {
1301 if {![catch {puts $f exit}]} {
1302 if {![catch {close $f}]} {
1310 # Deliberately call socket with the wrong number of arguments. The
1311 # error message you get will indicate whether sockets are available
1314 ConstraintInitializer
socket {
1316 string compare
$msg "sockets are not available on this system"
1319 # Check for internationalization
1320 ConstraintInitializer hasIsoLocale
{
1321 if {[llength [info commands testlocale
]] == 0} {
1324 set code
[string length
[SetIso8859_1_Locale
]]
1331 #####################################################################
1333 # Usage and command line arguments processing.
1335 # tcltest::PrintUsageInfo
1337 # Prints out the usage information for package tcltest. This can
1338 # be customized with the redefinition of [PrintUsageInfoHook].
1348 proc tcltest::PrintUsageInfo {} {
1353 proc tcltest::Usage { {option ""} } {
1356 if {[llength [info level
0]] == 1} {
1357 set msg
"Usage: [file tail [info nameofexecutable]] script "
1358 append msg
"?-help? ?flag value? ... \n"
1359 append msg
"Available flags (and valid input values) are:"
1362 set allOpts
[concat -help [Configure
]]
1363 foreach opt
$allOpts {
1364 set foo
[Usage
$opt]
1365 foreach [list x type
($opt) usage
($opt)] $foo break
1366 set line
($opt) " $opt $type($opt) "
1367 set length
($opt) [string length
$line($opt)]
1368 if {$length($opt) > $max} {set max
$length($opt)}
1370 set rest
[expr {72 - $max}]
1371 foreach opt
$allOpts {
1372 append msg
\n$line($opt)
1373 append msg
[string repeat
" " [expr {$max - $length($opt)}]]
1374 set u
[string trim
$usage($opt)]
1375 catch {append u
" (default: \[[Configure $opt]])"}
1376 regsub -all {\s
*\n\s
*} $u " " u
1377 while {[string length
$u] > $rest} {
1378 set break [string wordstart
$u $rest]
1380 set break [string wordend
$u 0]
1382 append msg
[string range
$u 0 [expr {$break - 1}]]
1383 set u
[string trim
[string range
$u $break end
]]
1384 append msg
\n[string repeat
" " $max]
1389 } elseif
{[string equal
-help $option]} {
1390 return [list -help "" "Display this usage information."]
1392 set type
[lindex [info args
$Verify($option)] 0]
1393 return [list $option $type $Usage($option)]
1397 # tcltest::ProcessFlags --
1399 # process command line arguments supplied in the flagArray - this
1400 # is called by processCmdLineArgs. Modifies tcltest variables
1401 # according to the content of the flagArray.
1404 # flagArray - array containing name/value pairs of flags
1407 # sets tcltest variables according to their values as defined by
1413 proc tcltest::ProcessFlags {flagArray
} {
1414 # Process -help first
1415 if {[lsearch -exact $flagArray {-help}] != -1} {
1420 if {[llength $flagArray] == 0} {
1421 RemoveAutoConfigureTraces
1424 while {[llength $args]>1 && [catch {eval configure
$args} msg
]} {
1426 # Something went wrong parsing $args for tcltest options
1427 # Check whether the problem is "unknown option"
1428 if {[regexp {^
unknown option (\S
+):} $msg -> option]} {
1429 # Could be this is an option the Hook knows about
1430 set moreOptions
[processCmdLineArgsAddFlagsHook
]
1431 if {[lsearch -exact $moreOptions $option] == -1} {
1432 # Nope. Report the error, including additional options,
1434 if {[llength $moreOptions]} {
1436 append msg
[join [lrange $moreOptions 0 end-1
] ", "]
1437 append msg
"or [lindex $moreOptions end]"
1442 # error is something other than "unknown option"
1443 # notify user of the error; and exit
1444 puts [errorChannel
] $msg
1448 # To recover, find that unknown option and remove up to it.
1450 while {![string equal
[lindex $args 0] $option]} {
1451 set args
[lrange $args 2 end
]
1453 set args
[lrange $args 2 end
]
1455 if {[llength $args] == 1} {
1456 puts [errorChannel
] \
1457 "missing value for option [lindex $args 0]"
1464 array set flag
$flagArray
1465 processCmdLineArgsHook
[array get flag
]
1470 # tcltest::ProcessCmdLineArgs --
1472 # This procedure must be run after constraint initialization is
1473 # set up (by [DefineConstraintInitializers]) because some constraints
1474 # can be overridden.
1476 # Perform configuration according to the command-line options.
1482 # Sets the above-named variables in the tcltest namespace.
1488 proc tcltest::ProcessCmdLineArgs {} {
1489 variable originalEnv
1490 variable testConstraints
1492 # The "argv" var doesn't exist in some cases, so use {}.
1493 if {![info exists
::argv]} {
1496 ProcessFlags
$::argv
1499 # Spit out everything you know if we're at a debug level 2 or
1501 DebugPuts
2 "Flags passed into tcltest:"
1502 if {[info exists
::env(TCLTEST_OPTIONS
)]} {
1504 " ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
1506 if {[info exists
::argv]} {
1507 DebugPuts
2 " argv: $::argv"
1509 DebugPuts
2 "tcltest::debug = [debug]"
1510 DebugPuts
2 "tcltest::testsDirectory = [testsDirectory]"
1511 DebugPuts
2 "tcltest::workingDirectory = [workingDirectory]"
1512 DebugPuts
2 "tcltest::temporaryDirectory = [temporaryDirectory]"
1513 DebugPuts
2 "tcltest::outputChannel = [outputChannel]"
1514 DebugPuts
2 "tcltest::errorChannel = [errorChannel]"
1515 DebugPuts
2 "Original environment (tcltest::originalEnv):"
1516 DebugPArray
2 originalEnv
1517 DebugPuts
2 "Constraints:"
1518 DebugPArray
2 testConstraints
1521 #####################################################################
1523 # Code to run the tests goes here.
1525 # tcltest::TestPuts --
1527 # Used to redefine puts in test environment. Stores whatever goes
1528 # out on stdout in tcltest::outData and stderr in errData before
1529 # sending it on to the regular puts.
1532 # same as standard puts
1538 # Intercepts puts; data that would otherwise go to stdout, stderr,
1539 # or file channels specified in outputChannel and errorChannel
1540 # does not get sent to the normal puts function.
1541 namespace eval tcltest::Replace {
1542 namespace export
puts
1544 proc tcltest::Replace::puts {args
} {
1545 variable [namespace parent
]::outData
1546 variable [namespace parent
]::errData
1547 switch [llength $args] {
1549 # Only the string to be printed is specified
1550 append outData
[lindex $args 0]\n
1552 # return [Puts [lindex $args 0]]
1555 # Either -nonewline or channelId has been specified
1556 if {[string equal
-nonewline [lindex $args 0]]} {
1557 append outData
[lindex $args end
]
1559 # return [Puts -nonewline [lindex $args end]]
1561 set channel
[lindex $args 0]
1566 if {[string equal
-nonewline [lindex $args 0]]} {
1567 # Both -nonewline and channelId are specified, unless
1568 # it's an error. -nonewline is supposed to be argv[0].
1569 set channel
[lindex $args 1]
1575 if {[info exists channel
]} {
1576 if {[string equal
$channel [[namespace parent
]::outputChannel]]
1577 ||
[string equal
$channel stdout
]} {
1578 append outData
[lindex $args end
]$newline
1580 } elseif
{[string equal
$channel [[namespace parent
]::errorChannel]]
1581 ||
[string equal
$channel stderr
]} {
1582 append errData
[lindex $args end
]$newline
1587 # If we haven't returned by now, we don't know how to handle the
1588 # input. Let puts handle it.
1589 return [eval Puts
$args]
1594 # Evaluate the script in the test environment. If ignoreOutput is
1595 # false, store data sent to stderr and stdout in outData and
1596 # errData. Otherwise, ignore this output altogether.
1599 # script Script to evaluate
1600 # ?ignoreOutput? Indicates whether or not to ignore output
1601 # sent to stdout & stderr
1604 # result from running the script
1607 # Empties the contents of outData and errData before running a
1608 # test if ignoreOutput is set to 0.
1610 proc tcltest::Eval {script
{ignoreOutput
1}} {
1613 DebugPuts
3 "[lindex [info level 0] 0] called"
1614 if {!$ignoreOutput} {
1617 rename ::puts [namespace current
]::Replace::Puts
1619 [list namespace import
[namespace origin Replace
::puts]]
1620 namespace import Replace
::puts
1622 set result
[uplevel 1 $script]
1623 if {!$ignoreOutput} {
1624 namespace forget
puts
1625 namespace eval :: namespace forget
puts
1626 rename [namespace current
]::Replace::Puts ::puts
1631 # tcltest::CompareStrings --
1633 # compares the expected answer to the actual answer, depending on
1634 # the mode provided. Mode determines whether a regexp, exact,
1635 # glob or custom comparison is done.
1638 # actual - string containing the actual result
1639 # expected - pattern to be matched against
1640 # mode - type of comparison to be done
1643 # result of the match
1648 proc tcltest::CompareStrings {actual expected mode
} {
1649 variable CustomMatch
1650 if {![info exists CustomMatch
($mode)]} {
1651 return -code error "No matching command registered for `-match $mode'"
1653 set match
[namespace eval :: $CustomMatch($mode) [list $expected $actual]]
1654 if {[catch {expr {$match && $match}} result
]} {
1655 return -code error "Invalid result from `-match $mode' command: $result"
1660 # tcltest::customMatch --
1662 # registers a command to be called when a particular type of
1663 # matching is required.
1666 # nickname - Keyword for the type of matching
1667 # cmd - Incomplete command that implements that type of matching
1668 # when completed with expected string and actual string
1669 # and then evaluated.
1675 # Sets the variable tcltest::CustomMatch
1677 proc tcltest::customMatch {mode script
} {
1678 variable CustomMatch
1679 if {![info complete
$script]} {
1680 return -code error \
1681 "invalid customMatch script; can't evaluate after completion"
1683 set CustomMatch
($mode) $script
1686 # tcltest::SubstArguments list
1688 # This helper function takes in a list of words, then perform a
1689 # substitution on the list as though each word in the list is a separate
1690 # argument to the Tcl function. For example, if this function is
1693 # SubstArguments {$a {$a}}
1695 # Then it is as though the function is invoked as:
1697 # SubstArguments $a {$a}
1699 # This code is adapted from Paul Duffin's function "SplitIntoWords".
1700 # The original function can be found on:
1702 # http://purl.org/thecliff/tcl/wiki/858.html
1705 # a list containing the result of the substitution
1708 # An error may occur if the list containing unbalanced quote or
1715 proc tcltest::SubstArguments {argList
} {
1717 # We need to split the argList up into tokens but cannot use list
1718 # operations as they throw away some significant quoting, and
1719 # [split] ignores braces as it should. Therefore what we do is
1720 # gradually build up a string out of whitespace seperated strings.
1721 # We cannot use [split] to split the argList into whitespace
1722 # separated strings as it throws away the whitespace which maybe
1723 # important so we have to do it all by hand.
1728 while {[string length
$argList]} {
1729 # Look for the next word containing a quote: " { }
1730 if {[regexp -indices {[^
\t\n]*[\"\{\}]+[^
\t\n]*} \
1732 # Get the text leading up to this word, but not including
1733 # this word, from the argList.
1734 set text [string range
$argList 0 \
1735 [expr {[lindex $all 0] - 1}]]
1736 # Get the word with the quote
1737 set word
[string range
$argList \
1738 [lindex $all 0] [lindex $all 1]]
1740 # Remove all text up to and including the word from the
1742 set argList
[string range
$argList \
1743 [expr {[lindex $all 1] + 1}] end
]
1745 # Take everything up to the end of the argList.
1752 # If we saw a word with quote before, then there is a
1753 # multi-word token starting with that word. In this case,
1754 # add the text and the current word to this token.
1755 append token
$text $word
1757 # Add the text to the result. There is no need to parse
1758 # the text because it couldn't be a part of any multi-word
1759 # token. Then start a new multi-word token with the word
1760 # because we need to pass this token to the Tcl parser to
1761 # check for balancing quotes
1766 if { [catch {llength $token} length
] == 0 && $length == 1} {
1767 # The token is a valid list so add it to the result.
1768 # lappend result [string trim $token]
1769 append result
\{$token\}
1774 # If the last token has not been added to the list then there
1776 if { [string length
$token] } {
1777 error "incomplete token \"$token\""
1786 # This procedure runs a test and prints an error message if the test
1787 # fails. If verbose has been set, it also prints a message even if the
1788 # test succeeds. The test will be skipped if it doesn't match the
1789 # match variable, if it matches an element in skip, or if one of the
1790 # elements of "constraints" turns out not to be true.
1792 # If testLevel is 1, then this is a top level test, and we record
1793 # pass/fail information; otherwise, this information is not logged and
1794 # is not added to running totals.
1797 # Only description is a required attribute. All others are optional.
1798 # Default values are indicated.
1800 # constraints - A list of one or more keywords, each of which
1801 # must be the name of an element in the array
1802 # "testConstraints". If any of these elements is
1803 # zero, the test is skipped. This attribute is
1804 # optional; default is {}
1805 # body - Script to run to carry out the test. It must
1806 # return a result that can be checked for
1807 # correctness. This attribute is optional;
1809 # result - Expected result from script. This attribute is
1810 # optional; default is {}.
1811 # output - Expected output sent to stdout. This attribute
1812 # is optional; default is {}.
1813 # errorOutput - Expected output sent to stderr. This attribute
1814 # is optional; default is {}.
1815 # returnCodes - Expected return codes. This attribute is
1816 # optional; default is {0 2}.
1817 # setup - Code to run before $script (above). This
1818 # attribute is optional; default is {}.
1819 # cleanup - Code to run after $script (above). This
1820 # attribute is optional; default is {}.
1821 # match - specifies type of matching to do on result,
1822 # output, errorOutput; this must be a string
1823 # previously registered by a call to [customMatch].
1824 # The strings exact, glob, and regexp are pre-registered
1825 # by the tcltest package. Default value is exact.
1828 # name - Name of test, in the form foo-1.2.
1829 # description - Short textual description of the test, to
1830 # help humans understand what it does.
1836 # Just about anything is possible depending on the test.
1839 proc tcltest::test {name description args
} {
1842 variable coreModTime
1843 DebugPuts
3 "test $name $args"
1847 puts "test name '$name' re-used; prior use in $TestNames($name)"
1849 set TestNames
($name) [info script
]
1855 # Pre-define everything to null except output and errorOutput. We
1856 # determine whether or not to trap output based on whether or not
1857 # these variables (output & errorOutput) are defined.
1858 foreach item
{constraints setup cleanup body result returnCodes
1863 # Set the default match mode
1866 # Set the default match values for return codes (0 is the standard
1867 # expected return value if everything went well; 2 represents
1868 # 'return' being used in the test script).
1869 set returnCodes
[list 0 2]
1871 # The old test format can't have a 3rd argument (constraints or
1872 # script) that starts with '-'.
1873 if {[string match
-* [lindex $args 0]]
1874 ||
([llength $args] <= 1)} {
1875 if {[llength $args] == 1} {
1876 set list [SubstArguments
[lindex $args 0]]
1877 foreach {element value
} $list {
1878 set testAttributes
($element) $value
1880 foreach item
{constraints match setup body cleanup
\
1881 result returnCodes output errorOutput
} {
1882 if {[info exists testAttributes
(-$item)]} {
1883 set testAttributes
(-$item) [uplevel 1 \
1884 ::concat $testAttributes(-$item)]
1888 array set testAttributes
$args
1891 set validFlags
{-setup -cleanup -body -result -returnCodes \
1892 -match -output -errorOutput -constraints}
1894 foreach flag
[array names testAttributes
] {
1895 if {[lsearch -exact $validFlags $flag] == -1} {
1897 set sorted
[lsort $validFlags]
1898 set options [join [lrange $sorted 0 end-1
] ", "]
1899 append options ", or [lindex $sorted end]"
1900 return -code error "bad option \"$flag\": must be $options"
1904 # store whatever the user gave us
1905 foreach item
[array names testAttributes
] {
1906 set [string trimleft
$item "-"] $testAttributes($item)
1909 # Check the values supplied for -match
1910 variable CustomMatch
1911 if {[lsearch [array names CustomMatch
] $match] == -1} {
1913 set sorted
[lsort [array names CustomMatch
]]
1914 set values
[join [lrange $sorted 0 end-1
] ", "]
1915 append values
", or [lindex $sorted end]"
1916 return -code error "bad -match value \"$match\":\
1920 # Replace symbolic valies supplied for -returnCodes
1921 foreach {strcode numcode
} {ok
0 normal
0 error 1 return 2 break 3 continue 4} {
1922 set returnCodes
[string map
-nocase [list $strcode $numcode] $returnCodes]
1925 # This is parsing for the old test command format; it is here
1926 # for backward compatibility.
1927 set result
[lindex $args end
]
1928 if {[llength $args] == 2} {
1929 set body
[lindex $args 0]
1930 } elseif
{[llength $args] == 3} {
1931 set constraints
[lindex $args 0]
1932 set body
[lindex $args 1]
1935 return -code error "wrong # args:\
1936 should be \"test name desc ?options?\""
1940 if {[Skipped
$name $constraints]} {
1945 # Save information about the core file.
1946 if {[preserveCore
]} {
1947 if {[file exists
[file join [workingDirectory
] core
]]} {
1948 set coreModTime
[file mtime
[file join [workingDirectory
] core
]]
1952 # First, run the setup script
1953 set code
[catch {uplevel 1 $setup} setupMsg
]
1955 set errorInfo
(setup
) $::errorInfo
1956 set errorCode
(setup
) $::errorCode
1958 set setupFailure
[expr {$code != 0}]
1960 # Only run the test body if the setup was successful
1961 if {!$setupFailure} {
1963 # Verbose notification of $body start
1964 if {[IsVerbose start
]} {
1965 puts [outputChannel
] "---- $name start"
1966 flush [outputChannel
]
1969 set command
[list [namespace origin RunTest
] $name $body]
1970 if {[info exists output
] ||
[info exists errorOutput
]} {
1971 set testResult
[uplevel 1 [list [namespace origin Eval
] $command 0]]
1973 set testResult
[uplevel 1 [list [namespace origin Eval
] $command 1]]
1975 foreach {actualAnswer returnCode
} $testResult break
1976 if {$returnCode == 1} {
1977 set errorInfo
(body
) $::errorInfo
1978 set errorCode
(body
) $::errorCode
1982 # Always run the cleanup script
1983 set code
[catch {uplevel 1 $cleanup} cleanupMsg
]
1985 set errorInfo
(cleanup
) $::errorInfo
1986 set errorCode
(cleanup
) $::errorCode
1988 set cleanupFailure
[expr {$code != 0}]
1992 # check for a core file first - if one was created by the test,
1993 # then the test failed
1994 if {[preserveCore
]} {
1995 if {[file exists
[file join [workingDirectory
] core
]]} {
1996 # There's only a test failure if there is a core file
1997 # and (1) there previously wasn't one or (2) the new
1998 # one is different from the old one.
1999 if {[info exists coreModTime
]} {
2000 if {$coreModTime != [file mtime
\
2001 [file join [workingDirectory
] core
]]} {
2008 if {([preserveCore
] > 1) && ($coreFailure)} {
2009 append coreMsg
"\nMoving file to:\
2010 [file join [temporaryDirectory] core-$name]"
2011 catch {file rename -force \
2012 [file join [workingDirectory
] core
] \
2013 [file join [temporaryDirectory
] core-
$name]
2015 if {[string length
$msg] > 0} {
2016 append coreMsg
"\nError:\
2017 Problem renaming core file: $msg"
2023 # check if the return code matched the expected return code
2025 if {!$setupFailure && [lsearch -exact $returnCodes $returnCode] == -1} {
2029 # If expected output/error strings exist, we have to compare
2030 # them. If the comparison fails, then so did the test.
2033 if {[info exists output
] && !$codeFailure} {
2034 if {[set outputCompare
[catch {
2035 CompareStrings
$outData $output $match
2036 } outputMatch
]] == 0} {
2037 set outputFailure
[expr {!$outputMatch}]
2045 if {[info exists errorOutput
] && !$codeFailure} {
2046 if {[set errorCompare
[catch {
2047 CompareStrings
$errData $errorOutput $match
2048 } errorMatch
]] == 0} {
2049 set errorFailure
[expr {!$errorMatch}]
2055 # check if the answer matched the expected answer
2056 # Only check if we ran the body of the test (no setup failure)
2057 if {$setupFailure ||
$codeFailure} {
2059 } elseif
{[set scriptCompare
[catch {
2060 CompareStrings
$actualAnswer $result $match
2061 } scriptMatch
]] == 0} {
2062 set scriptFailure
[expr {!$scriptMatch}]
2067 # if we didn't experience any failures, then we passed
2069 if {!($setupFailure ||
$cleanupFailure ||
$coreFailure
2070 ||
$outputFailure ||
$errorFailure ||
$codeFailure
2071 ||
$scriptFailure)} {
2072 if {$testLevel == 1} {
2073 incr numTests
(Passed
)
2074 if {[IsVerbose pass
]} {
2075 puts [outputChannel
] "++++ $name PASSED"
2082 # We know the test failed, tally it...
2083 if {$testLevel == 1} {
2084 incr numTests
(Failed
)
2087 # ... then report according to the type of failure
2088 variable currentFailure true
2089 if {![IsVerbose body
]} {
2092 puts [outputChannel
] "\n"
2093 if {[IsVerbose line
]} {
2094 set testFile
[file normalize
[uplevel 1 {info script
}]]
2095 if {[file readable
$testFile]} {
2096 set testFd
[open $testFile r
]
2097 set lineNo
[expr {[lsearch -regexp [split [read $testFd] "\n"] \
2098 "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
2100 puts [outputChannel
] "$testFile:$lineNo: test failed:\
2101 $name [string trim $description]"
2104 puts [outputChannel
] "==== $name\
2105 [string trim $description] FAILED"
2106 if {[string length
$body]} {
2107 puts [outputChannel
] "==== Contents of test case:"
2108 puts [outputChannel
] $body
2110 if {$setupFailure} {
2111 puts [outputChannel
] "---- Test setup\
2113 if {[info exists errorInfo
(setup
)]} {
2114 puts [outputChannel
] "---- errorInfo(setup): $errorInfo(setup)"
2115 puts [outputChannel
] "---- errorCode(setup): $errorCode(setup)"
2118 if {$scriptFailure} {
2119 if {$scriptCompare} {
2120 puts [outputChannel
] "---- Error testing result: $scriptMatch"
2122 puts [outputChannel
] "---- Result was:\n$actualAnswer"
2123 puts [outputChannel
] "---- Result should have been\
2124 ($match matching):\n$result"
2128 switch -- $returnCode {
2129 0 { set msg
"Test completed normally" }
2130 1 { set msg
"Test generated error" }
2131 2 { set msg
"Test generated return exception" }
2132 3 { set msg
"Test generated break exception" }
2133 4 { set msg
"Test generated continue exception" }
2134 default { set msg
"Test generated exception" }
2136 puts [outputChannel
] "---- $msg; Return code was: $returnCode"
2137 puts [outputChannel
] "---- Return code should have been\
2138 one of: $returnCodes"
2139 if {[IsVerbose
error]} {
2140 if {[info exists errorInfo
(body
)] && ([lsearch $returnCodes 1]<0)} {
2141 puts [outputChannel
] "---- errorInfo: $errorInfo(body)"
2142 puts [outputChannel
] "---- errorCode: $errorCode(body)"
2146 if {$outputFailure} {
2147 if {$outputCompare} {
2148 puts [outputChannel
] "---- Error testing output: $outputMatch"
2150 puts [outputChannel
] "---- Output was:\n$outData"
2151 puts [outputChannel
] "---- Output should have been\
2152 ($match matching):\n$output"
2155 if {$errorFailure} {
2156 if {$errorCompare} {
2157 puts [outputChannel
] "---- Error testing errorOutput: $errorMatch"
2159 puts [outputChannel
] "---- Error output was:\n$errData"
2160 puts [outputChannel
] "---- Error output should have\
2161 been ($match matching):\n$errorOutput"
2164 if {$cleanupFailure} {
2165 puts [outputChannel
] "---- Test cleanup failed:\n$cleanupMsg"
2166 if {[info exists errorInfo
(cleanup
)]} {
2167 puts [outputChannel
] "---- errorInfo(cleanup): $errorInfo(cleanup)"
2168 puts [outputChannel
] "---- errorCode(cleanup): $errorCode(cleanup)"
2172 puts [outputChannel
] "---- Core file produced while running\
2175 puts [outputChannel
] "==== $name FAILED\n"
2183 # Given a test name and it constraints, returns a boolean indicating
2184 # whether the current configuration says the test should be skipped.
2186 # Side Effects: Maintains tally of total tests seen and tests skipped.
2188 proc tcltest::Skipped {name constraints
} {
2191 variable testConstraints
2193 if {$testLevel == 1} {
2194 incr numTests
(Total
)
2196 # skip the test if it's name matches an element of skip
2197 foreach pattern
[skip
] {
2198 if {[string match
$pattern $name]} {
2199 if {$testLevel == 1} {
2200 incr numTests
(Skipped
)
2201 DebugDo
1 {AddToSkippedBecause userSpecifiedSkip
}
2206 # skip the test if it's name doesn't match any element of match
2208 foreach pattern
[match
] {
2209 if {[string match
$pattern $name]} {
2215 if {$testLevel == 1} {
2216 incr numTests
(Skipped
)
2217 DebugDo
1 {AddToSkippedBecause userSpecifiedNonMatch
}
2221 if {[string equal
{} $constraints]} {
2222 # If we're limited to the listed constraints and there aren't
2223 # any listed, then we shouldn't run the test.
2224 if {[limitConstraints
]} {
2225 AddToSkippedBecause userSpecifiedLimitConstraint
2226 if {$testLevel == 1} {
2227 incr numTests
(Skipped
)
2232 # "constraints" argument exists;
2233 # make sure that the constraints are satisfied.
2236 if {[string match
{*[$\[]*} $constraints] != 0} {
2237 # full expression, e.g. {$foo > [info tclversion]}
2238 catch {set doTest
[uplevel #0 expr $constraints]}
2239 } elseif
{[regexp {[^.a-zA-Z0-9
\n\r\t]+} $constraints] != 0} {
2240 # something like {a || b} should be turned into
2241 # $testConstraints(a) || $testConstraints(b).
2242 regsub -all {[.
\w
]+} $constraints {$testConstraints(&)} c
2243 catch {set doTest
[eval expr $c]}
2244 } elseif
{![catch {llength $constraints}]} {
2245 # just simple constraints such as {unixOnly fonts}.
2247 foreach constraint
$constraints {
2248 if {(![info exists testConstraints
($constraint)]) \
2249 ||
(!$testConstraints($constraint))} {
2252 # store the constraint that kept the test from
2254 set constraints
$constraint
2261 if {[IsVerbose skip
]} {
2262 puts [outputChannel
] "++++ $name SKIPPED: $constraints"
2265 if {$testLevel == 1} {
2266 incr numTests
(Skipped
)
2267 AddToSkippedBecause
$constraints
2277 # This is where the body of a test is evaluated. The combination of
2278 # [RunTest] and [Eval] allows the output and error output of the test
2279 # body to be captured for comparison against the expected values.
2281 proc tcltest::RunTest {name script
} {
2282 DebugPuts
3 "Running $name {$script}"
2284 # If there is no "memory" command (because memory debugging isn't
2285 # enabled), then don't attempt to use the command.
2287 if {[llength [info commands
memory]] == 1} {
2291 set code
[catch {uplevel 1 $script} actualAnswer
]
2293 return [list $actualAnswer $code]
2296 #####################################################################
2298 # tcltest::cleanupTestsHook --
2300 # This hook allows a harness that builds upon tcltest to specify
2301 # additional things that should be done at cleanup.
2304 if {[llength [info commands
tcltest::cleanupTestsHook]] == 0} {
2305 proc tcltest::cleanupTestsHook {} {}
2308 # tcltest::cleanupTests --
2310 # Remove files and dirs created using the makeFile and makeDirectory
2311 # commands since the last time this proc was invoked.
2313 # Print the names of the files created without the makeFile command
2314 # since the tests were invoked.
2316 # Print the number tests (total, passed, failed, and skipped) since the
2317 # tests were invoked.
2319 # Restore original environment (as reported by special variable env).
2322 # calledFromAllFile - if 0, behave as if we are running a single
2323 # test file within an entire suite of tests. if we aren't running
2324 # a single test file, then don't report status. check for new
2325 # files created during the test run and report on them. if 1,
2326 # report collated status from all the test file runs.
2335 proc tcltest::cleanupTests {{calledFromAllFile
0}} {
2337 variable filesExisted
2338 variable createdNewFiles
2339 variable testSingleFile
2341 variable numTestFiles
2343 variable skippedBecause
2344 variable currentFailure
2345 variable originalEnv
2346 variable originalTclPlatform
2347 variable coreModTime
2350 set testFileName
[file tail
[info script
]]
2352 # Call the cleanup hook
2355 # Remove files and directories created by the makeFile and
2356 # makeDirectory procedures. Record the names of files in
2357 # workingDirectory that were not pre-existing, and associate them
2358 # with the test file that created them.
2360 if {!$calledFromAllFile} {
2361 foreach file $filesMade {
2362 if {[file exists
$file]} {
2363 DebugDo
1 {Warn
"cleanupTests deleting $file..."}
2364 catch {file delete
-force $file}
2368 foreach file [glob -nocomplain \
2369 -directory [temporaryDirectory
] *] {
2370 lappend currentFiles
[file tail
$file]
2373 foreach file $currentFiles {
2374 if {[lsearch -exact $filesExisted $file] == -1} {
2375 lappend newFiles
$file
2378 set filesExisted
$currentFiles
2379 if {[llength $newFiles] > 0} {
2380 set createdNewFiles
($testFileName) $newFiles
2384 if {$calledFromAllFile ||
$testSingleFile} {
2388 puts -nonewline [outputChannel
] "$testFileName:"
2389 foreach index
[list "Total" "Passed" "Skipped" "Failed"] {
2390 puts -nonewline [outputChannel
] \
2391 "\t$index\t$numTests($index)"
2393 puts [outputChannel
] ""
2395 # print number test files sourced
2396 # print names of files that ran tests which failed
2398 if {$calledFromAllFile} {
2399 puts [outputChannel
] \
2400 "Sourced $numTestFiles Test Files."
2402 if {[llength $failFiles] > 0} {
2403 puts [outputChannel
] \
2404 "Files with failing tests: $failFiles"
2409 # if any tests were skipped, print the constraints that kept
2410 # them from running.
2412 set constraintList
[array names skippedBecause
]
2413 if {[llength $constraintList] > 0} {
2414 puts [outputChannel
] \
2415 "Number of tests skipped for each constraint:"
2416 foreach constraint
[lsort $constraintList] {
2417 puts [outputChannel
] \
2418 "\t$skippedBecause($constraint)\t$constraint"
2419 unset skippedBecause
($constraint)
2423 # report the names of test files in createdNewFiles, and reset
2424 # the array to be empty.
2426 set testFilesThatTurded
[lsort [array names createdNewFiles
]]
2427 if {[llength $testFilesThatTurded] > 0} {
2428 puts [outputChannel
] "Warning: files left behind:"
2429 foreach testFile
$testFilesThatTurded {
2430 puts [outputChannel
] \
2431 "\t$testFile:\t$createdNewFiles($testFile)"
2432 unset createdNewFiles
($testFile)
2436 # reset filesMade, filesExisted, and numTests
2439 foreach index
[list "Total" "Passed" "Skipped" "Failed"] {
2440 set numTests
($index) 0
2443 # exit only if running Tk in non-interactive mode
2444 # This should be changed to determine if an event
2445 # loop is running, which is the real issue.
2446 # Actually, this doesn't belong here at all. A package
2447 # really has no business [exit]-ing an application.
2448 if {![catch {package present Tk
}] && ![testConstraint interactive
]} {
2453 # if we're deferring stat-reporting until all files are sourced,
2454 # then add current file to failFile list if any tests in this
2457 if {$currentFailure \
2458 && ([lsearch -exact $failFiles $testFileName] == -1)} {
2459 lappend failFiles
$testFileName
2461 set currentFailure false
2463 # restore the environment to the state it was in before this package
2469 foreach index
[array names
::env] {
2470 if {![info exists originalEnv
($index)]} {
2471 lappend newEnv
$index
2474 if {$::env($index) != $originalEnv($index)} {
2475 lappend changedEnv
$index
2476 set ::env($index) $originalEnv($index)
2480 foreach index
[array names originalEnv
] {
2481 if {![info exists
::env($index)]} {
2482 lappend removedEnv
$index
2483 set ::env($index) $originalEnv($index)
2486 if {[llength $newEnv] > 0} {
2487 puts [outputChannel
] \
2488 "env array elements created:\t$newEnv"
2490 if {[llength $changedEnv] > 0} {
2491 puts [outputChannel
] \
2492 "env array elements changed:\t$changedEnv"
2494 if {[llength $removedEnv] > 0} {
2495 puts [outputChannel
] \
2496 "env array elements removed:\t$removedEnv"
2499 set changedTclPlatform
{}
2500 foreach index
[array names originalTclPlatform
] {
2501 if {$::tcl_platform($index) \
2502 != $originalTclPlatform($index)} {
2503 lappend changedTclPlatform
$index
2504 set ::tcl_platform($index) $originalTclPlatform($index)
2507 if {[llength $changedTclPlatform] > 0} {
2508 puts [outputChannel
] "tcl_platform array elements\
2509 changed:\t$changedTclPlatform"
2512 if {[file exists
[file join [workingDirectory
] core
]]} {
2513 if {[preserveCore
] > 1} {
2514 puts "rename core file (> 1)"
2515 puts [outputChannel
] "produced core file! \
2517 [file join [temporaryDirectory] core-$testFileName]"
2518 catch {file rename -force \
2519 [file join [workingDirectory
] core
] \
2520 [file join [temporaryDirectory
] core-
$testFileName]
2522 if {[string length
$msg] > 0} {
2523 PrintError
"Problem renaming file: $msg"
2526 # Print a message if there is a core file and (1) there
2527 # previously wasn't one or (2) the new one is different
2530 if {[info exists coreModTime
]} {
2531 if {$coreModTime != [file mtime
\
2532 [file join [workingDirectory
] core
]]} {
2533 puts [outputChannel
] "A core file was created!"
2536 puts [outputChannel
] "A core file was created!"
2541 flush [outputChannel
]
2542 flush [errorChannel
]
2546 #####################################################################
2548 # Procs that determine which tests/test files to run
2550 # tcltest::GetMatchingFiles
2552 # Looks at the patterns given to match and skip files and uses
2553 # them to put together a list of the tests that will be run.
2556 # directory to search
2559 # The constructed list is returned to the user. This will
2560 # primarily be used in 'all.tcl' files. It is used in
2566 # a lower case version is needed for compatibility with tcltest 1.0
2567 proc tcltest::getMatchingFiles args
{eval GetMatchingFiles
$args}
2569 proc tcltest::GetMatchingFiles { args
} {
2570 if {[llength $args]} {
2573 # Finding tests only in [testsDirectory] is normal operation.
2574 # This procedure is written to accept multiple directory arguments
2575 # only to satisfy version 1 compatibility.
2576 set dirList
[list [testsDirectory
]]
2579 set matchingFiles
[list]
2580 foreach directory
$dirList {
2582 # List files in $directory that match patterns to run.
2583 set matchFileList
[list]
2584 foreach match
[matchFiles
] {
2585 set matchFileList
[concat $matchFileList \
2586 [glob -directory $directory -types {b c f p s
} \
2587 -nocomplain -- $match]]
2590 # List files in $directory that match patterns to skip.
2591 set skipFileList
[list]
2592 foreach skip
[skipFiles
] {
2593 set skipFileList
[concat $skipFileList \
2594 [glob -directory $directory -types {b c f p s
} \
2595 -nocomplain -- $skip]]
2598 # Add to result list all files in match list and not in skip list
2599 foreach file $matchFileList {
2600 if {[lsearch -exact $skipFileList $file] == -1} {
2601 lappend matchingFiles
$file
2606 if {[llength $matchingFiles] == 0} {
2607 PrintError
"No test files remain after applying your match and\
2610 return $matchingFiles
2613 # tcltest::GetMatchingDirectories --
2615 # Looks at the patterns given to match and skip directories and
2616 # uses them to put together a list of the test directories that we
2617 # should attempt to run. (Only subdirectories containing an
2618 # "all.tcl" file are put into the list.)
2621 # root directory from which to search
2624 # The constructed list is returned to the user. This is used in
2625 # the primary all.tcl file.
2630 proc tcltest::GetMatchingDirectories {rootdir
} {
2632 # Determine the skip list first, to avoid [glob]-ing over subdirectories
2633 # we're going to throw away anyway. Be sure we skip the $rootdir if it
2634 # comes up to avoid infinite loops.
2635 set skipDirs
[list $rootdir]
2636 foreach pattern
[skipDirectories
] {
2637 set skipDirs
[concat $skipDirs [glob -directory $rootdir -types d
\
2638 -nocomplain -- $pattern]]
2641 # Now step through the matching directories, prune out the skipped ones
2643 set matchDirs
[list]
2644 foreach pattern
[matchDirectories
] {
2645 foreach path
[glob -directory $rootdir -types d
-nocomplain -- \
2647 if {[lsearch -exact $skipDirs $path] == -1} {
2648 set matchDirs
[concat $matchDirs [GetMatchingDirectories
$path]]
2649 if {[file exists
[file join $path all.tcl
]]} {
2650 lappend matchDirs
$path
2656 if {[llength $matchDirs] == 0} {
2657 DebugPuts
1 "No test directories remain after applying match\
2663 # tcltest::runAllTests --
2665 # prints output and sources test files according to the match and
2666 # skip patterns provided. after sourcing test files, it goes on
2667 # to source all.tcl files in matching test subdirectories.
2670 # shell being tested
2678 proc tcltest::runAllTests { {shell
""} } {
2679 variable testSingleFile
2680 variable numTestFiles
2685 if {[llength [info level
0]] == 1} {
2686 set shell
[interpreter
]
2689 set testSingleFile false
2691 puts [outputChannel
] "Tests running in interp: $shell"
2692 puts [outputChannel
] "Tests located in: [testsDirectory]"
2693 puts [outputChannel
] "Tests running in: [workingDirectory]"
2694 puts [outputChannel
] "Temporary files stored in\
2695 [temporaryDirectory]"
2697 # [file system] first available in Tcl 8.4
2698 if {![catch {file system
[testsDirectory
]} result
]
2699 && ![string equal native
[lindex $result 0]]} {
2700 # If we aren't running in the native filesystem, then we must
2701 # run the tests in a single process (via 'source'), because
2702 # trying to run then via a pipe will fail since the files don't
2707 if {[singleProcess
]} {
2708 puts [outputChannel
] \
2709 "Test files sourced into current interpreter"
2711 puts [outputChannel
] \
2712 "Test files run in separate interpreters"
2714 if {[llength [skip
]] > 0} {
2715 puts [outputChannel
] "Skipping tests that match: [skip]"
2717 puts [outputChannel
] "Running tests that match: [match]"
2719 if {[llength [skipFiles
]] > 0} {
2720 puts [outputChannel
] \
2721 "Skipping test files that match: [skipFiles]"
2723 if {[llength [matchFiles
]] > 0} {
2724 puts [outputChannel
] \
2725 "Only running test files that match: [matchFiles]"
2728 set timeCmd
{clock format [clock seconds
]}
2729 puts [outputChannel
] "Tests began at [eval $timeCmd]"
2731 # Run each of the specified tests
2732 foreach file [lsort [GetMatchingFiles
]] {
2733 set tail
[file tail
$file]
2734 puts [outputChannel
] $tail
2735 flush [outputChannel
]
2737 if {[singleProcess
]} {
2739 uplevel 1 [list ::source $file]
2741 # Pass along our configuration to the child processes.
2742 # EXCEPT for the -outfile, because the parent process
2743 # needs to read and process output of children.
2744 set childargv
[list]
2745 foreach opt
[Configure
] {
2746 if {[string equal
$opt -outfile]} {continue}
2747 lappend childargv
$opt [Configure
$opt]
2749 set cmd
[linsert $childargv 0 |
$shell $file]
2752 set pipeFd
[open $cmd "r"]
2753 while {[gets $pipeFd line
] >= 0} {
2757 {Passed
\t([0-9]+)\t}
2758 {Skipped
\t([0-9]+)\t}
2760 } ""] $line null testFile
\
2761 Total Passed Skipped Failed
]} {
2762 foreach index
{Total Passed Skipped Failed
} {
2763 incr numTests
($index) [set $index]
2766 lappend failFiles
$testFile
2768 } elseif
{[regexp [join {
2769 {^Number of tests skipped
}
2770 {for each constraint
:}
2772 } ""] $line match skipped constraint
]} {
2773 if {[string match
\t* $match]} {
2774 AddToSkippedBecause
$constraint $skipped
2777 puts [outputChannel
] $line
2782 puts [outputChannel
] "Test file error: $msg"
2783 # append the name of the test to a list to be reported
2785 lappend testFileFailures
$file
2791 puts [outputChannel
] "\nTests ended at [eval $timeCmd]"
2793 if {[info exists testFileFailures
]} {
2794 puts [outputChannel
] "\nTest files exiting with errors: \n"
2795 foreach file $testFileFailures {
2796 puts [outputChannel
] " [file tail $file]\n"
2800 # Checking for subdirectories in which to run tests
2801 foreach directory
[GetMatchingDirectories
[testsDirectory
]] {
2802 set dir
[file tail
$directory]
2803 puts [outputChannel
] [string repeat ~
44]
2804 puts [outputChannel
] "$dir test began at [eval $timeCmd]\n"
2806 uplevel 1 [list ::source [file join $directory all.tcl
]]
2808 set endTime
[eval $timeCmd]
2809 puts [outputChannel
] "\n$dir test ended at $endTime"
2810 puts [outputChannel
] ""
2811 puts [outputChannel
] [string repeat ~
44]
2816 #####################################################################
2818 # Test utility procs - not used in tcltest, but may be useful for
2821 # tcltest::loadTestedCommands --
2823 # Uses the specified script to load the commands to test. Allowed to
2824 # be empty, as the tested commands could have been compiled into the
2836 proc tcltest::loadTestedCommands {} {
2838 if {[string equal
{} [loadScript
]]} {
2842 return [uplevel 1 [loadScript
]]
2845 # tcltest::saveState --
2847 # Save information regarding what procs and variables exist.
2853 # Modifies the variable saveState
2858 proc tcltest::saveState {} {
2860 uplevel 1 [list ::set [namespace which
-variable saveState
]] \
2861 {[::list [::info procs
] [::info vars
]]}
2862 DebugPuts
2 "[lindex [info level 0] 0]: $saveState"
2866 # tcltest::restoreState --
2868 # Remove procs and variables that didn't exist before the call to
2875 # Removes procs and variables from your environment if they don't
2876 # exist in the saveState variable.
2881 proc tcltest::restoreState {} {
2883 foreach p
[uplevel 1 {::info procs
}] {
2884 if {([lsearch [lindex $saveState 0] $p] < 0)
2885 && ![string equal
[namespace current
]::$p \
2886 [uplevel 1 [list ::namespace origin
$p]]]} {
2888 DebugPuts
2 "[lindex [info level 0] 0]: Removing proc $p"
2889 uplevel 1 [list ::catch [list ::rename $p {}]]
2892 foreach p
[uplevel 1 {::info vars
}] {
2893 if {[lsearch [lindex $saveState 1] $p] < 0} {
2894 DebugPuts
2 "[lindex [info level 0] 0]:\
2895 Removing variable $p"
2896 uplevel 1 [list ::catch [list ::unset $p]]
2902 # tcltest::normalizeMsg --
2904 # Removes "extra" newlines from a string.
2907 # msg String to be modified
2910 # string with extra newlines removed
2915 proc tcltest::normalizeMsg {msg
} {
2916 regsub "\n$" [string tolower
$msg] "" msg
2917 set msg
[string map
[list "\n\n" "\n"] $msg]
2918 return [string map
[list "\n\}" "\}"] $msg]
2921 # tcltest::makeFile --
2923 # Create a new file with the name <name>, and write <contents> to it.
2925 # If this file hasn't been created via makeFile since the last time
2926 # cleanupTests was called, add it to the $filesMade list, so it will be
2927 # removed by the next call to cleanupTests.
2930 # contents content of the new file
2931 # name name of the new file
2932 # directory directory name for new file
2935 # absolute path to the file created
2940 proc tcltest::makeFile {contents name
{directory
""}} {
2944 if {[llength [info level
0]] == 3} {
2945 set directory
[temporaryDirectory
]
2948 set fullName
[file join $directory $name]
2950 DebugPuts
3 "[lindex [info level 0] 0]:\
2951 putting ``$contents'' into $fullName"
2953 set fd
[open $fullName w
]
2954 fconfigure $fd -translation lf
2955 if {[string equal
[string index
$contents end
] \n]} {
2956 puts -nonewline $fd $contents
2962 if {[lsearch -exact $filesMade $fullName] == -1} {
2963 lappend filesMade
$fullName
2968 # tcltest::removeFile --
2970 # Removes the named file from the filesystem
2973 # name file to be removed
2974 # directory directory from which to remove file
2977 # return value from [file delete]
2982 proc tcltest::removeFile {name
{directory
""}} {
2985 if {[llength [info level
0]] == 2} {
2986 set directory
[temporaryDirectory
]
2988 set fullName
[file join $directory $name]
2989 DebugPuts
3 "[lindex [info level 0] 0]: removing $fullName"
2990 set idx
[lsearch -exact $filesMade $fullName]
2991 set filesMade
[lreplace $filesMade $idx $idx]
2994 Warn
"removeFile removing \"$fullName\":\n not created by makeFile"
2997 if {![file isfile
$fullName]} {
2999 Warn
"removeFile removing \"$fullName\":\n not a file"
3002 return [file delete
$fullName]
3005 # tcltest::makeDirectory --
3007 # Create a new dir with the name <name>.
3009 # If this dir hasn't been created via makeDirectory since the last time
3010 # cleanupTests was called, add it to the $directoriesMade list, so it
3011 # will be removed by the next call to cleanupTests.
3014 # name name of the new directory
3015 # directory directory in which to create new dir
3018 # absolute path to the directory created
3023 proc tcltest::makeDirectory {name
{directory
""}} {
3026 if {[llength [info level
0]] == 2} {
3027 set directory
[temporaryDirectory
]
3029 set fullName
[file join $directory $name]
3030 DebugPuts
3 "[lindex [info level 0] 0]: creating $fullName"
3031 file mkdir
$fullName
3032 if {[lsearch -exact $filesMade $fullName] == -1} {
3033 lappend filesMade
$fullName
3038 # tcltest::removeDirectory --
3040 # Removes a named directory from the file system.
3043 # name Name of the directory to remove
3044 # directory Directory from which to remove
3047 # return value from [file delete]
3052 proc tcltest::removeDirectory {name
{directory
""}} {
3055 if {[llength [info level
0]] == 2} {
3056 set directory
[temporaryDirectory
]
3058 set fullName
[file join $directory $name]
3059 DebugPuts
3 "[lindex [info level 0] 0]: deleting $fullName"
3060 set idx
[lsearch -exact $filesMade $fullName]
3061 set filesMade
[lreplace $filesMade $idx $idx]
3064 Warn
"removeDirectory removing \"$fullName\":\n not created\
3068 if {![file isdirectory
$fullName]} {
3070 Warn
"removeDirectory removing \"$fullName\":\n not a directory"
3073 return [file delete
-force $fullName]
3076 # tcltest::viewFile --
3078 # reads the content of a file and returns it
3081 # name of the file to read
3082 # directory in which file is located
3085 # content of the named file
3090 proc tcltest::viewFile {name
{directory
""}} {
3092 if {[llength [info level
0]] == 2} {
3093 set directory
[temporaryDirectory
]
3095 set fullName
[file join $directory $name]
3096 set f
[open $fullName]
3097 set data
[read -nonewline $f]
3102 # tcltest::bytestring --
3104 # Construct a string that consists of the requested sequence of bytes,
3105 # as opposed to a string of properly formed UTF-8 characters.
3106 # This allows the tester to
3107 # 1. Create denormalized or improperly formed strings to pass to C
3108 # procedures that are supposed to accept strings with embedded NULL
3110 # 2. Confirm that a string result has a certain pattern of bytes, for
3111 # instance to confirm that "\xe0\0" in a Tcl script is stored
3112 # internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
3114 # Generally, it's a bad idea to examine the bytes in a Tcl string or to
3115 # construct improperly formed strings in this manner, because it involves
3116 # exposing that Tcl uses UTF-8 internally.
3119 # string being converted
3122 # result fom encoding
3127 proc tcltest::bytestring {string} {
3128 return [encoding convertfrom identity
$string]
3131 # tcltest::OpenFiles --
3133 # used in io tests, uses testchannel
3144 proc tcltest::OpenFiles {} {
3145 if {[catch {testchannel
open} result
]} {
3151 # tcltest::LeakFiles --
3153 # used in io tests, uses testchannel
3164 proc tcltest::LeakFiles {old
} {
3165 if {[catch {testchannel
open} new
]} {
3170 if {[lsearch $old $p] < 0} {
3178 # Internationalization / ISO support procs -- dl
3181 # tcltest::SetIso8859_1_Locale --
3183 # used in cmdIL.test, uses testlocale
3194 proc tcltest::SetIso8859_1_Locale {} {
3195 variable previousLocale
3197 if {[info commands testlocale
] != ""} {
3198 set previousLocale
[testlocale ctype
]
3199 testlocale ctype
$isoLocale
3204 # tcltest::RestoreLocale --
3206 # used in cmdIL.test, uses testlocale
3217 proc tcltest::RestoreLocale {} {
3218 variable previousLocale
3219 if {[info commands testlocale
] != ""} {
3220 testlocale ctype
$previousLocale
3225 # tcltest::threadReap --
3227 # Kill all threads except for the main thread.
3228 # Do nothing if testthread is not defined.
3234 # Returns the number of existing threads.
3240 proc tcltest::threadReap {} {
3241 if {[info commands testthread
] != {}} {
3243 # testthread built into tcltest
3245 testthread errorproc ThreadNullError
3246 while {[llength [testthread names
]] > 1} {
3247 foreach tid
[testthread names
] {
3248 if {$tid != [mainThread
]} {
3250 testthread
send -async $tid {testthread
exit}
3254 ## Enter a bit a sleep to give the threads enough breathing
3255 ## room to kill themselves off, otherwise the end up with a
3256 ## massive queue of repeated events
3259 testthread errorproc ThreadError
3260 return [llength [testthread names
]]
3261 } elseif
{[info commands thread
::id] != {}} {
3265 thread
::errorproc ThreadNullError
3266 while {[llength [thread
::names]] > 1} {
3267 foreach tid
[thread
::names] {
3268 if {$tid != [mainThread
]} {
3269 catch {thread
::send -async $tid {thread
::exit}}
3272 ## Enter a bit a sleep to give the threads enough breathing
3273 ## room to kill themselves off, otherwise the end up with a
3274 ## massive queue of repeated events
3277 thread
::errorproc ThreadError
3278 return [llength [thread
::names]]
3285 # Initialize the constraints and set up command line arguments
3286 namespace eval tcltest {
3287 # Define initializers for all the built-in contraint definitions
3288 DefineConstraintInitializers
3290 # Set up the constraints in the testConstraints array to be lazily
3291 # initialized by a registered initializer, or by "false" if no
3292 # initializer is registered.
3293 trace variable testConstraints r
[namespace code SafeFetch
]
3295 # Only initialize constraints at package load time if an
3296 # [initConstraintsHook] has been pre-defined. This is only
3297 # for compatibility support. The modern way to add a custom
3298 # test constraint is to just call the [testConstraint] command
3299 # straight away, without all this "hook" nonsense.
3300 if {[string equal
[namespace current
] \
3301 [namespace qualifiers
[namespace which initConstraintsHook
]]]} {
3304 proc initConstraintsHook
{} {}
3307 # Define the standard match commands
3308 customMatch exact
[list string equal
]
3309 customMatch
glob [list string match
]
3310 customMatch
regexp [list regexp --]
3312 # If the TCLTEST_OPTIONS environment variable exists, configure
3313 # tcltest according to the option values it specifies. This has
3314 # the effect of resetting tcltest's default configuration.
3315 proc ConfigureFromEnvironment
{} {
3316 upvar #0 env(TCLTEST_OPTIONS) options
3317 if {[catch {llength $options} msg
]} {
3318 Warn
"invalid TCLTEST_OPTIONS \"$options\":\n invalid\
3322 if {[llength $::env(TCLTEST_OPTIONS
)] % 2} {
3323 Warn
"invalid TCLTEST_OPTIONS: \"$options\":\n should be\
3324 -option value ?-option value ...?"
3327 if {[catch {eval Configure
$::env(TCLTEST_OPTIONS
)} msg
]} {
3328 Warn
"invalid TCLTEST_OPTIONS: \"$options\":\n $msg"
3332 if {[info exists
::env(TCLTEST_OPTIONS
)]} {
3333 ConfigureFromEnvironment
3336 proc LoadTimeCmdLineArgParsingRequired
{} {
3338 if {[info exists
::argv] && [lsearch -exact $::argv -help] != -1} {
3339 # The command line asks for -help, so give it (and exit)
3340 # right now. ([configure] does not process -help)
3343 foreach hook
{ PrintUsageInfoHook processCmdLineArgsHook
3344 processCmdLineArgsAddFlagsHook
} {
3345 if {[string equal
[namespace current
] [namespace qualifiers
\
3346 [namespace which
$hook]]]} {
3355 # Only initialize configurable options from the command line arguments
3356 # at package load time if necessary for backward compatibility. This
3357 # lets the tcltest user call [configure] for themselves if they wish.
3358 # Traces are established for auto-configuration from the command line
3359 # if any configurable options are accessed before the user calls
3361 if {[LoadTimeCmdLineArgParsingRequired
]} {
3364 EstablishAutoConfigureTraces
3367 package provide
[namespace tail
[namespace current
]] $Version