Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/Media/tcl8.4/tcltest/tcltest.tcl @ 5198

Last change on this file since 5198 was 5167, checked in by rgrieder, 16 years ago

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