Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: data/trunk/tcl8.5/tcltest/tcltest.tcl @ 5617

Last change on this file since 5617 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: 97.2 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.103 2007/12/13 15:26:03 dgp Exp $
20
21package require Tcl 8.5         ;# -verbose line uses [info frame]
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.3.0
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|line)$} $level]} {
613                # translate single characters abbreviations to expanded list
614                set level [string map {p pass b body s skip t start e error l line} \
615                        [split $level {}]]
616            }
617        }
618        set valid [list]
619        foreach v $level {
620            if {[regexp {^(pass|body|skip|start|error|line)$} $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', 'e' and 'l'.
635        Test suite will display all passed tests if 'p' is specified, all
636        skipped tests if 's' is specified, the bodies of failed tests if
637        'b' is specified, and when tests start if 't' is specified.
638        ErrorInfo is displayed if 'e' is specified. Source file line
639        information of failed tests is displayed if 'l' is specified.
640    } AcceptVerbose verbose
641
642    # Match and skip patterns default to the empty list, except for
643    # matchFiles, which defaults to all .test files in the
644    # testsDirectory and matchDirectories, which defaults to all
645    # directories.
646    Option -match * {
647        Run all tests within the specified files that match one of the
648        list of glob patterns given.
649    } AcceptList match
650
651    Option -skip {} {
652        Skip all tests within the specified tests (via -match) and files
653        that match one of the list of glob patterns given.
654    } AcceptList skip
655
656    Option -file *.test {
657        Run tests in all test files that match the glob pattern given.
658    } AcceptPattern matchFiles
659
660    # By default, skip files that appear to be SCCS lock files.
661    Option -notfile l.*.test {
662        Skip all test files that match the glob pattern given.
663    } AcceptPattern skipFiles
664
665    Option -relateddir * {
666        Run tests in directories that match the glob pattern given.
667    } AcceptPattern matchDirectories
668
669    Option -asidefromdir {} {
670        Skip tests in directories that match the glob pattern given.
671    } AcceptPattern skipDirectories
672
673    # By default, don't save core files
674    Option -preservecore 0 {
675        If 2, save any core files produced during testing in the directory
676        specified by -tmpdir. If 1, notify the user if core files are
677        created.
678    } AcceptInteger preserveCore
679
680    # debug output doesn't get printed by default; debug level 1 spits
681    # up only the tests that were skipped because they didn't match or
682    # were specifically skipped.  A debug level of 2 would spit up the
683    # tcltest variables and flags provided; a debug level of 3 causes
684    # some additional output regarding operations of the test harness.
685    # The tcltest package currently implements only up to debug level 3.
686    Option -debug 0 {
687        Internal debug level
688    } AcceptInteger debug
689
690    proc SetSelectedConstraints args {
691        variable Option
692        foreach c $Option(-constraints) {
693            testConstraint $c 1
694        }
695    }
696    Option -constraints {} {
697        Do not skip the listed constraints listed in -constraints.
698    } AcceptList
699    trace variable Option(-constraints) w \
700            [namespace code {SetSelectedConstraints ;#}]
701
702    # Don't run only the "-constraint" specified tests by default
703    proc ClearUnselectedConstraints args {
704        variable Option
705        variable testConstraints
706        if {!$Option(-limitconstraints)} {return}
707        foreach c [array names testConstraints] {
708            if {[lsearch -exact $Option(-constraints) $c] == -1} {
709                testConstraint $c 0
710            }
711        }
712    }
713    Option -limitconstraints false {
714        whether to run only tests with the constraints
715    } AcceptBoolean limitConstraints
716    trace variable Option(-limitconstraints) w \
717            [namespace code {ClearUnselectedConstraints ;#}]
718
719    # A test application has to know how to load the tested commands
720    # into the interpreter.
721    Option -load {} {
722        Specifies the script to load the tested commands.
723    } AcceptScript loadScript
724
725    # Default is to run each test file in a separate process
726    Option -singleproc 0 {
727        whether to run all tests in one process
728    } AcceptBoolean singleProcess
729
730    proc AcceptTemporaryDirectory { directory } {
731        set directory [AcceptAbsolutePath $directory]
732        if {![file exists $directory]} {
733            file mkdir $directory
734        }
735        set directory [AcceptDirectory $directory]
736        if {![file writable $directory]} {
737            if {[string equal [workingDirectory] $directory]} {
738                # Special exception: accept the default value
739                # even if the directory is not writable
740                return $directory
741            }
742            return -code error "\"$directory\" is not writeable"
743        }
744        return $directory
745    }
746
747    # Directory where files should be created
748    Option -tmpdir [workingDirectory] {
749        Save temporary files in the specified directory.
750    } AcceptTemporaryDirectory temporaryDirectory
751    trace variable Option(-tmpdir) w \
752            [namespace code {normalizePath Option(-tmpdir) ;#}]
753
754    # Tests should not rely on the current working directory.
755    # Files that are part of the test suite should be accessed relative
756    # to [testsDirectory]
757    Option -testdir [workingDirectory] {
758        Search tests in the specified directory.
759    } AcceptDirectory testsDirectory
760    trace variable Option(-testdir) w \
761            [namespace code {normalizePath Option(-testdir) ;#}]
762
763    proc AcceptLoadFile { file } {
764        if {[string equal "" $file]} {return $file}
765        set file [file join [temporaryDirectory] $file]
766        return [AcceptReadable $file]
767    }
768    proc ReadLoadScript {args} {
769        variable Option
770        if {[string equal "" $Option(-loadfile)]} {return}
771        set tmp [open $Option(-loadfile) r]
772        loadScript [read $tmp]
773        close $tmp
774    }
775    Option -loadfile {} {
776        Read the script to load the tested commands from the specified file.
777    } AcceptLoadFile loadFile
778    trace variable Option(-loadfile) w [namespace code ReadLoadScript]
779
780    proc AcceptOutFile { file } {
781        if {[string equal stderr $file]} {return $file}
782        if {[string equal stdout $file]} {return $file}
783        return [file join [temporaryDirectory] $file]
784    }
785
786    # output goes to stdout by default
787    Option -outfile stdout {
788        Send output from test runs to the specified file.
789    } AcceptOutFile outputFile
790    trace variable Option(-outfile) w \
791            [namespace code {outputChannel $Option(-outfile) ;#}]
792
793    # errors go to stderr by default
794    Option -errfile stderr {
795        Send errors from test runs to the specified file.
796    } AcceptOutFile errorFile
797    trace variable Option(-errfile) w \
798            [namespace code {errorChannel $Option(-errfile) ;#}]
799
800}
801
802#####################################################################
803
804# tcltest::Debug* --
805#
806#     Internal helper procedures to write out debug information
807#     dependent on the chosen level. A test shell may overide
808#     them, f.e. to redirect the output into a different
809#     channel, or even into a GUI.
810
811# tcltest::DebugPuts --
812#
813#     Prints the specified string if the current debug level is
814#     higher than the provided level argument.
815#
816# Arguments:
817#     level   The lowest debug level triggering the output
818#     string  The string to print out.
819#
820# Results:
821#     Prints the string. Nothing else is allowed.
822#
823# Side Effects:
824#     None.
825#
826
827proc tcltest::DebugPuts {level string} {
828    variable debug
829    if {$debug >= $level} {
830        puts $string
831    }
832    return
833}
834
835# tcltest::DebugPArray --
836#
837#     Prints the contents of the specified array if the current
838#       debug level is higher than the provided level argument
839#
840# Arguments:
841#     level           The lowest debug level triggering the output
842#     arrayvar        The name of the array to print out.
843#
844# Results:
845#     Prints the contents of the array. Nothing else is allowed.
846#
847# Side Effects:
848#     None.
849#
850
851proc tcltest::DebugPArray {level arrayvar} {
852    variable debug
853
854    if {$debug >= $level} {
855        catch {upvar  $arrayvar $arrayvar}
856        parray $arrayvar
857    }
858    return
859}
860
861# Define our own [parray] in ::tcltest that will inherit use of the [puts]
862# defined in ::tcltest.  NOTE: Ought to construct with [info args] and
863# [info default], but can't be bothered now.  If [parray] changes, then
864# this will need changing too.
865auto_load ::parray
866proc tcltest::parray {a {pattern *}} [info body ::parray]
867
868# tcltest::DebugDo --
869#
870#     Executes the script if the current debug level is greater than
871#       the provided level argument
872#
873# Arguments:
874#     level   The lowest debug level triggering the execution.
875#     script  The tcl script executed upon a debug level high enough.
876#
877# Results:
878#     Arbitrary side effects, dependent on the executed script.
879#
880# Side Effects:
881#     None.
882#
883
884proc tcltest::DebugDo {level script} {
885    variable debug
886
887    if {$debug >= $level} {
888        uplevel 1 $script
889    }
890    return
891}
892
893#####################################################################
894
895proc tcltest::Warn {msg} {
896    puts [outputChannel] "WARNING: $msg"
897}
898
899# tcltest::mainThread
900#
901#     Accessor command for tcltest variable mainThread.
902#
903proc tcltest::mainThread { {new ""} } {
904    variable mainThread
905    if {[llength [info level 0]] == 1} {
906        return $mainThread
907    }
908    set mainThread $new
909}
910
911# tcltest::testConstraint --
912#
913#       sets a test constraint to a value; to do multiple constraints,
914#       call this proc multiple times.  also returns the value of the
915#       named constraint if no value was supplied.
916#
917# Arguments:
918#       constraint - name of the constraint
919#       value - new value for constraint (should be boolean) - if not
920#               supplied, this is a query
921#
922# Results:
923#       content of tcltest::testConstraints($constraint)
924#
925# Side effects:
926#       none
927
928proc tcltest::testConstraint {constraint {value ""}} {
929    variable testConstraints
930    variable Option
931    DebugPuts 3 "entering testConstraint $constraint $value"
932    if {[llength [info level 0]] == 2} {
933        return $testConstraints($constraint)
934    }
935    # Check for boolean values
936    if {[catch {expr {$value && $value}} msg]} {
937        return -code error $msg
938    }
939    if {[limitConstraints] 
940            && [lsearch -exact $Option(-constraints) $constraint] == -1} {
941        set value 0
942    }
943    set testConstraints($constraint) $value
944}
945
946# tcltest::interpreter --
947#
948#       the interpreter name stored in tcltest::tcltest
949#
950# Arguments:
951#       executable name
952#
953# Results:
954#       content of tcltest::tcltest
955#
956# Side effects:
957#       None.
958
959proc tcltest::interpreter { {interp ""} } {
960    variable tcltest
961    if {[llength [info level 0]] == 1} {
962        return $tcltest
963    }
964    if {[string equal {} $interp]} {
965        set tcltest {}
966    } else {
967        set tcltest $interp
968    }
969}
970
971#####################################################################
972
973# tcltest::AddToSkippedBecause --
974#
975#       Increments the variable used to track how many tests were
976#       skipped because of a particular constraint.
977#
978# Arguments:
979#       constraint     The name of the constraint to be modified
980#
981# Results:
982#       Modifies tcltest::skippedBecause; sets the variable to 1 if
983#       didn't previously exist - otherwise, it just increments it.
984#
985# Side effects:
986#       None.
987
988proc tcltest::AddToSkippedBecause { constraint {value 1}} {
989    # add the constraint to the list of constraints that kept tests
990    # from running
991    variable skippedBecause
992
993    if {[info exists skippedBecause($constraint)]} {
994        incr skippedBecause($constraint) $value
995    } else {
996        set skippedBecause($constraint) $value
997    }
998    return
999}
1000
1001# tcltest::PrintError --
1002#
1003#       Prints errors to tcltest::errorChannel and then flushes that
1004#       channel, making sure that all messages are < 80 characters per
1005#       line.
1006#
1007# Arguments:
1008#       errorMsg     String containing the error to be printed
1009#
1010# Results:
1011#       None.
1012#
1013# Side effects:
1014#       None.
1015
1016proc tcltest::PrintError {errorMsg} {
1017    set InitialMessage "Error:  "
1018    set InitialMsgLen  [string length $InitialMessage]
1019    puts -nonewline [errorChannel] $InitialMessage
1020
1021    # Keep track of where the end of the string is.
1022    set endingIndex [string length $errorMsg]
1023
1024    if {$endingIndex < (80 - $InitialMsgLen)} {
1025        puts [errorChannel] $errorMsg
1026    } else {
1027        # Print up to 80 characters on the first line, including the
1028        # InitialMessage.
1029        set beginningIndex [string last " " [string range $errorMsg 0 \
1030                [expr {80 - $InitialMsgLen}]]]
1031        puts [errorChannel] [string range $errorMsg 0 $beginningIndex]
1032
1033        while {![string equal end $beginningIndex]} {
1034            puts -nonewline [errorChannel] \
1035                    [string repeat " " $InitialMsgLen]
1036            if {($endingIndex - $beginningIndex)
1037                    < (80 - $InitialMsgLen)} {
1038                puts [errorChannel] [string trim \
1039                        [string range $errorMsg $beginningIndex end]]
1040                break
1041            } else {
1042                set newEndingIndex [expr {[string last " " \
1043                        [string range $errorMsg $beginningIndex \
1044                                [expr {$beginningIndex
1045                                        + (80 - $InitialMsgLen)}]
1046                ]] + $beginningIndex}]
1047                if {($newEndingIndex <= 0)
1048                        || ($newEndingIndex <= $beginningIndex)} {
1049                    set newEndingIndex end
1050                }
1051                puts [errorChannel] [string trim \
1052                        [string range $errorMsg \
1053                            $beginningIndex $newEndingIndex]]
1054                set beginningIndex $newEndingIndex
1055            }
1056        }
1057    }
1058    flush [errorChannel]
1059    return
1060}
1061
1062# tcltest::SafeFetch --
1063#
1064#        The following trace procedure makes it so that we can safely
1065#        refer to non-existent members of the testConstraints array
1066#        without causing an error.  Instead, reading a non-existent
1067#        member will return 0. This is necessary because tests are
1068#        allowed to use constraint "X" without ensuring that
1069#        testConstraints("X") is defined.
1070#
1071# Arguments:
1072#       n1 - name of the array (testConstraints)
1073#       n2 - array key value (constraint name)
1074#       op - operation performed on testConstraints (generally r)
1075#
1076# Results:
1077#       none
1078#
1079# Side effects:
1080#       sets testConstraints($n2) to 0 if it's referenced but never
1081#       before used
1082
1083proc tcltest::SafeFetch {n1 n2 op} {
1084    variable testConstraints
1085    DebugPuts 3 "entering SafeFetch $n1 $n2 $op"
1086    if {[string equal {} $n2]} {return}
1087    if {![info exists testConstraints($n2)]} {
1088        if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} {
1089            testConstraint $n2 0
1090        }
1091    }
1092}
1093
1094# tcltest::ConstraintInitializer --
1095#
1096#       Get or set a script that when evaluated in the tcltest namespace
1097#       will return a boolean value with which to initialize the
1098#       associated constraint.
1099#
1100# Arguments:
1101#       constraint - name of the constraint initialized by the script
1102#       script - the initializer script
1103#
1104# Results
1105#       boolean value of the constraint - enabled or disabled
1106#
1107# Side effects:
1108#       Constraint is initialized for future reference by [test]
1109proc tcltest::ConstraintInitializer {constraint {script ""}} {
1110    variable ConstraintInitializer
1111    DebugPuts 3 "entering ConstraintInitializer $constraint $script"
1112    if {[llength [info level 0]] == 2} {
1113        return $ConstraintInitializer($constraint)
1114    }
1115    # Check for boolean values
1116    if {![info complete $script]} {
1117        return -code error "ConstraintInitializer must be complete script"
1118    }
1119    set ConstraintInitializer($constraint) $script
1120}
1121
1122# tcltest::InitConstraints --
1123#
1124# Call all registered constraint initializers to force initialization
1125# of all known constraints.
1126# See the tcltest man page for the list of built-in constraints defined
1127# in this procedure.
1128#
1129# Arguments:
1130#       none
1131#
1132# Results:
1133#       The testConstraints array is reset to have an index for each
1134#       built-in test constraint.
1135#
1136# Side Effects:
1137#       None.
1138#
1139
1140proc tcltest::InitConstraints {} {
1141    variable ConstraintInitializer
1142    initConstraintsHook
1143    foreach constraint [array names ConstraintInitializer] {
1144        testConstraint $constraint
1145    }
1146}
1147
1148proc tcltest::DefineConstraintInitializers {} {
1149    ConstraintInitializer singleTestInterp {singleProcess}
1150
1151    # All the 'pc' constraints are here for backward compatibility and
1152    # are not documented.  They have been replaced with equivalent 'win'
1153    # constraints.
1154
1155    ConstraintInitializer unixOnly \
1156            {string equal $::tcl_platform(platform) unix}
1157    ConstraintInitializer macOnly \
1158            {string equal $::tcl_platform(platform) macintosh}
1159    ConstraintInitializer pcOnly \
1160            {string equal $::tcl_platform(platform) windows}
1161    ConstraintInitializer winOnly \
1162            {string equal $::tcl_platform(platform) windows}
1163
1164    ConstraintInitializer unix {testConstraint unixOnly}
1165    ConstraintInitializer mac {testConstraint macOnly}
1166    ConstraintInitializer pc {testConstraint pcOnly}
1167    ConstraintInitializer win {testConstraint winOnly}
1168
1169    ConstraintInitializer unixOrPc \
1170            {expr {[testConstraint unix] || [testConstraint pc]}}
1171    ConstraintInitializer macOrPc \
1172            {expr {[testConstraint mac] || [testConstraint pc]}}
1173    ConstraintInitializer unixOrWin \
1174            {expr {[testConstraint unix] || [testConstraint win]}}
1175    ConstraintInitializer macOrWin \
1176            {expr {[testConstraint mac] || [testConstraint win]}}
1177    ConstraintInitializer macOrUnix \
1178            {expr {[testConstraint mac] || [testConstraint unix]}}
1179
1180    ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
1181    ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
1182    ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
1183
1184    # The following Constraints switches are used to mark tests that
1185    # should work, but have been temporarily disabled on certain
1186    # platforms because they don't and we haven't gotten around to
1187    # fixing the underlying problem.
1188
1189    ConstraintInitializer tempNotPc {expr {![testConstraint pc]}}
1190    ConstraintInitializer tempNotWin {expr {![testConstraint win]}}
1191    ConstraintInitializer tempNotMac {expr {![testConstraint mac]}}
1192    ConstraintInitializer tempNotUnix {expr {![testConstraint unix]}}
1193
1194    # The following Constraints switches are used to mark tests that
1195    # crash on certain platforms, so that they can be reactivated again
1196    # when the underlying problem is fixed.
1197
1198    ConstraintInitializer pcCrash {expr {![testConstraint pc]}}
1199    ConstraintInitializer winCrash {expr {![testConstraint win]}}
1200    ConstraintInitializer macCrash {expr {![testConstraint mac]}}
1201    ConstraintInitializer unixCrash {expr {![testConstraint unix]}}
1202
1203    # Skip empty tests
1204
1205    ConstraintInitializer emptyTest {format 0}
1206
1207    # By default, tests that expose known bugs are skipped.
1208
1209    ConstraintInitializer knownBug {format 0}
1210
1211    # By default, non-portable tests are skipped.
1212
1213    ConstraintInitializer nonPortable {format 0}
1214
1215    # Some tests require user interaction.
1216
1217    ConstraintInitializer userInteraction {format 0}
1218
1219    # Some tests must be skipped if the interpreter is not in
1220    # interactive mode
1221
1222    ConstraintInitializer interactive \
1223            {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
1224
1225    # Some tests can only be run if the installation came from a CD
1226    # image instead of a web image.  Some tests must be skipped if you
1227    # are running as root on Unix.  Other tests can only be run if you
1228    # are running as root on Unix.
1229
1230    ConstraintInitializer root {expr \
1231            {[string equal unix $::tcl_platform(platform)]
1232            && ([string equal root $::tcl_platform(user)]
1233                || [string equal "" $::tcl_platform(user)])}}
1234    ConstraintInitializer notRoot {expr {![testConstraint root]}}
1235
1236    # Set nonBlockFiles constraint: 1 means this platform supports
1237    # setting files into nonblocking mode.
1238
1239    ConstraintInitializer nonBlockFiles {
1240            set code [expr {[catch {set f [open defs r]}] 
1241                    || [catch {fconfigure $f -blocking off}]}]
1242            catch {close $f}
1243            set code
1244    }
1245
1246    # Set asyncPipeClose constraint: 1 means this platform supports
1247    # async flush and async close on a pipe.
1248    #
1249    # Test for SCO Unix - cannot run async flushing tests because a
1250    # potential problem with select is apparently interfering.
1251    # (Mark Diekhans).
1252
1253    ConstraintInitializer asyncPipeClose {expr {
1254            !([string equal unix $::tcl_platform(platform)] 
1255            && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
1256
1257    # Test to see if we have a broken version of sprintf with respect
1258    # to the "e" format of floating-point numbers.
1259
1260    ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
1261
1262    # Test to see if execed commands such as cat, echo, rm and so forth
1263    # are present on this machine.
1264
1265    ConstraintInitializer unixExecs {
1266        set code 1
1267        if {[string equal macintosh $::tcl_platform(platform)]} {
1268            set code 0
1269        }
1270        if {[string equal windows $::tcl_platform(platform)]} {
1271            if {[catch {
1272                set file _tcl_test_remove_me.txt
1273                makeFile {hello} $file
1274            }]} {
1275                set code 0
1276            } elseif {
1277                [catch {exec cat $file}] ||
1278                [catch {exec echo hello}] ||
1279                [catch {exec sh -c echo hello}] ||
1280                [catch {exec wc $file}] ||
1281                [catch {exec sleep 1}] ||
1282                [catch {exec echo abc > $file}] ||
1283                [catch {exec chmod 644 $file}] ||
1284                [catch {exec rm $file}] ||
1285                [llength [auto_execok mkdir]] == 0 ||
1286                [llength [auto_execok fgrep]] == 0 ||
1287                [llength [auto_execok grep]] == 0 ||
1288                [llength [auto_execok ps]] == 0
1289            } {
1290                set code 0
1291            }
1292            removeFile $file
1293        }
1294        set code
1295    }
1296
1297    ConstraintInitializer stdio {
1298        set code 0
1299        if {![catch {set f [open "|[list [interpreter]]" w]}]} {
1300            if {![catch {puts $f exit}]} {
1301                if {![catch {close $f}]} {
1302                    set code 1
1303                }
1304            }
1305        }
1306        set code
1307    }
1308
1309    # Deliberately call socket with the wrong number of arguments.  The
1310    # error message you get will indicate whether sockets are available
1311    # on this system.
1312
1313    ConstraintInitializer socket {
1314        catch {socket} msg
1315        string compare $msg "sockets are not available on this system"
1316    }
1317
1318    # Check for internationalization
1319    ConstraintInitializer hasIsoLocale {
1320        if {[llength [info commands testlocale]] == 0} {
1321            set code 0
1322        } else {
1323            set code [string length [SetIso8859_1_Locale]]
1324            RestoreLocale
1325        }
1326        set code
1327    }
1328
1329}
1330#####################################################################
1331
1332# Usage and command line arguments processing.
1333
1334# tcltest::PrintUsageInfo
1335#
1336#       Prints out the usage information for package tcltest.  This can
1337#       be customized with the redefinition of [PrintUsageInfoHook].
1338#
1339# Arguments:
1340#       none
1341#
1342# Results:
1343#       none
1344#
1345# Side Effects:
1346#       none
1347proc tcltest::PrintUsageInfo {} {
1348    puts [Usage]
1349    PrintUsageInfoHook
1350}
1351
1352proc tcltest::Usage { {option ""} } {
1353    variable Usage
1354    variable Verify
1355    if {[llength [info level 0]] == 1} {
1356        set msg "Usage: [file tail [info nameofexecutable]] script "
1357        append msg "?-help? ?flag value? ... \n"
1358        append msg "Available flags (and valid input values) are:"
1359
1360        set max 0
1361        set allOpts [concat -help [Configure]]
1362        foreach opt $allOpts {
1363            set foo [Usage $opt]
1364            foreach [list x type($opt) usage($opt)] $foo break
1365            set line($opt) "  $opt $type($opt)  "
1366            set length($opt) [string length $line($opt)]
1367            if {$length($opt) > $max} {set max $length($opt)}
1368        }
1369        set rest [expr {72 - $max}]
1370        foreach opt $allOpts {
1371            append msg \n$line($opt)
1372            append msg [string repeat " " [expr {$max - $length($opt)}]]
1373            set u [string trim $usage($opt)]
1374            catch {append u "  (default: \[[Configure $opt]])"}
1375            regsub -all {\s*\n\s*} $u " " u
1376            while {[string length $u] > $rest} {
1377                set break [string wordstart $u $rest]
1378                if {$break == 0} {
1379                    set break [string wordend $u 0]
1380                }
1381                append msg [string range $u 0 [expr {$break - 1}]]
1382                set u [string trim [string range $u $break end]]
1383                append msg \n[string repeat " " $max]
1384            }
1385            append msg $u
1386        }
1387        return $msg\n
1388    } elseif {[string equal -help $option]} {
1389        return [list -help "" "Display this usage information."]
1390    } else {
1391        set type [lindex [info args $Verify($option)] 0]
1392        return [list $option $type $Usage($option)]
1393    }
1394}
1395
1396# tcltest::ProcessFlags --
1397#
1398#       process command line arguments supplied in the flagArray - this
1399#       is called by processCmdLineArgs.  Modifies tcltest variables
1400#       according to the content of the flagArray.
1401#
1402# Arguments:
1403#       flagArray - array containing name/value pairs of flags
1404#
1405# Results:
1406#       sets tcltest variables according to their values as defined by
1407#       flagArray
1408#
1409# Side effects:
1410#       None.
1411
1412proc tcltest::ProcessFlags {flagArray} {
1413    # Process -help first
1414    if {[lsearch -exact $flagArray {-help}] != -1} {
1415        PrintUsageInfo
1416        exit 1
1417    }
1418
1419    if {[llength $flagArray] == 0} {
1420        RemoveAutoConfigureTraces
1421    } else {
1422        set args $flagArray
1423        while {[llength $args]>1 && [catch {eval configure $args} msg]} {
1424
1425            # Something went wrong parsing $args for tcltest options
1426            # Check whether the problem is "unknown option"
1427            if {[regexp {^unknown option (\S+):} $msg -> option]} {
1428                # Could be this is an option the Hook knows about
1429                set moreOptions [processCmdLineArgsAddFlagsHook]
1430                if {[lsearch -exact $moreOptions $option] == -1} {
1431                    # Nope.  Report the error, including additional options,
1432                    # but keep going
1433                    if {[llength $moreOptions]} {
1434                        append msg ", "
1435                        append msg [join [lrange $moreOptions 0 end-1] ", "]
1436                        append msg "or [lindex $moreOptions end]"
1437                    }
1438                    Warn $msg
1439                }
1440            } else {
1441                # error is something other than "unknown option"
1442                # notify user of the error; and exit
1443                puts [errorChannel] $msg
1444                exit 1
1445            }
1446
1447            # To recover, find that unknown option and remove up to it.
1448            # then retry
1449            while {![string equal [lindex $args 0] $option]} {
1450                set args [lrange $args 2 end]
1451            }
1452            set args [lrange $args 2 end]
1453        }
1454        if {[llength $args] == 1} {
1455            puts [errorChannel] \
1456                    "missing value for option [lindex $args 0]"
1457            exit 1
1458        }
1459    }
1460
1461    # Call the hook
1462    catch {
1463        array set flag $flagArray
1464        processCmdLineArgsHook [array get flag]
1465    }
1466    return
1467}
1468
1469# tcltest::ProcessCmdLineArgs --
1470#
1471#       This procedure must be run after constraint initialization is
1472#       set up (by [DefineConstraintInitializers]) because some constraints
1473#       can be overridden.
1474#
1475#       Perform configuration according to the command-line options.
1476#
1477# Arguments:
1478#       none
1479#
1480# Results:
1481#       Sets the above-named variables in the tcltest namespace.
1482#
1483# Side Effects:
1484#       None.
1485#
1486
1487proc tcltest::ProcessCmdLineArgs {} {
1488    variable originalEnv
1489    variable testConstraints
1490
1491    # The "argv" var doesn't exist in some cases, so use {}.
1492    if {![info exists ::argv]} {
1493        ProcessFlags {}
1494    } else {
1495        ProcessFlags $::argv
1496    }
1497
1498    # Spit out everything you know if we're at a debug level 2 or
1499    # greater
1500    DebugPuts 2 "Flags passed into tcltest:"
1501    if {[info exists ::env(TCLTEST_OPTIONS)]} {
1502        DebugPuts 2 \
1503                "    ::env(TCLTEST_OPTIONS): $::env(TCLTEST_OPTIONS)"
1504    }
1505    if {[info exists ::argv]} {
1506        DebugPuts 2 "    argv: $::argv"
1507    }
1508    DebugPuts    2 "tcltest::debug              = [debug]"
1509    DebugPuts    2 "tcltest::testsDirectory     = [testsDirectory]"
1510    DebugPuts    2 "tcltest::workingDirectory   = [workingDirectory]"
1511    DebugPuts    2 "tcltest::temporaryDirectory = [temporaryDirectory]"
1512    DebugPuts    2 "tcltest::outputChannel      = [outputChannel]"
1513    DebugPuts    2 "tcltest::errorChannel       = [errorChannel]"
1514    DebugPuts    2 "Original environment (tcltest::originalEnv):"
1515    DebugPArray  2 originalEnv
1516    DebugPuts    2 "Constraints:"
1517    DebugPArray  2 testConstraints
1518}
1519
1520#####################################################################
1521
1522# Code to run the tests goes here.
1523
1524# tcltest::TestPuts --
1525#
1526#       Used to redefine puts in test environment.  Stores whatever goes
1527#       out on stdout in tcltest::outData and stderr in errData before
1528#       sending it on to the regular puts.
1529#
1530# Arguments:
1531#       same as standard puts
1532#
1533# Results:
1534#       none
1535#
1536# Side effects:
1537#       Intercepts puts; data that would otherwise go to stdout, stderr,
1538#       or file channels specified in outputChannel and errorChannel
1539#       does not get sent to the normal puts function.
1540namespace eval tcltest::Replace {
1541    namespace export puts
1542}
1543proc tcltest::Replace::puts {args} {
1544    variable [namespace parent]::outData
1545    variable [namespace parent]::errData
1546    switch [llength $args] {
1547        1 {
1548            # Only the string to be printed is specified
1549            append outData [lindex $args 0]\n
1550            return
1551            # return [Puts [lindex $args 0]]
1552        }
1553        2 {
1554            # Either -nonewline or channelId has been specified
1555            if {[string equal -nonewline [lindex $args 0]]} {
1556                append outData [lindex $args end]
1557                return
1558                # return [Puts -nonewline [lindex $args end]]
1559            } else {
1560                set channel [lindex $args 0]
1561                set newline \n
1562            }
1563        }
1564        3 {
1565            if {[string equal -nonewline [lindex $args 0]]} {
1566                # Both -nonewline and channelId are specified, unless
1567                # it's an error.  -nonewline is supposed to be argv[0].
1568                set channel [lindex $args 1]
1569                set newline ""
1570            }
1571        }
1572    }
1573
1574    if {[info exists channel]} {
1575        if {[string equal $channel [[namespace parent]::outputChannel]]
1576                || [string equal $channel stdout]} {
1577            append outData [lindex $args end]$newline
1578            return
1579        } elseif {[string equal $channel [[namespace parent]::errorChannel]]
1580                || [string equal $channel stderr]} {
1581            append errData [lindex $args end]$newline
1582            return
1583        }
1584    }
1585
1586    # If we haven't returned by now, we don't know how to handle the
1587    # input.  Let puts handle it.
1588    return [eval Puts $args]
1589}
1590
1591# tcltest::Eval --
1592#
1593#       Evaluate the script in the test environment.  If ignoreOutput is
1594#       false, store data sent to stderr and stdout in outData and
1595#       errData.  Otherwise, ignore this output altogether.
1596#
1597# Arguments:
1598#       script             Script to evaluate
1599#       ?ignoreOutput?     Indicates whether or not to ignore output
1600#                          sent to stdout & stderr
1601#
1602# Results:
1603#       result from running the script
1604#
1605# Side effects:
1606#       Empties the contents of outData and errData before running a
1607#       test if ignoreOutput is set to 0.
1608
1609proc tcltest::Eval {script {ignoreOutput 1}} {
1610    variable outData
1611    variable errData
1612    DebugPuts 3 "[lindex [info level 0] 0] called"
1613    if {!$ignoreOutput} {
1614        set outData {}
1615        set errData {}
1616        rename ::puts [namespace current]::Replace::Puts
1617        namespace eval :: [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"
2091    if {[IsVerbose line]} {
2092        if {![catch {set testFrame [info frame -1]}] &&
2093                [dict get $testFrame type] eq "source"} {
2094            set testFile [dict get $testFrame file]
2095            set testLine [dict get $testFrame line]
2096        } else {
2097            set testFile [file normalize [uplevel 1 {info script}]]
2098            if {[file readable $testFile]} {
2099                set testFd [open $testFile r]
2100                set testLine [expr {[lsearch -regexp \
2101                        [split [read $testFd] "\n"] \
2102                        "^\[ \t\]*test [string map {. \\.} $name] "]+1}]
2103                close $testFd
2104            }
2105        }
2106        if {[info exists testLine]} {
2107            puts [outputChannel] "$testFile:$testLine: test failed:\
2108                    $name [string trim $description]"
2109        }
2110    }   
2111    puts [outputChannel] "==== $name\
2112            [string trim $description] FAILED"
2113    if {[string length $body]} {
2114        puts [outputChannel] "==== Contents of test case:"
2115        puts [outputChannel] $body
2116    }
2117    if {$setupFailure} {
2118        puts [outputChannel] "---- Test setup\
2119                failed:\n$setupMsg"
2120        if {[info exists errorInfo(setup)]} {
2121            puts [outputChannel] "---- errorInfo(setup): $errorInfo(setup)"
2122            puts [outputChannel] "---- errorCode(setup): $errorCode(setup)"
2123        }
2124    }
2125    if {$scriptFailure} {
2126        if {$scriptCompare} {
2127            puts [outputChannel] "---- Error testing result: $scriptMatch"
2128        } else {
2129            puts [outputChannel] "---- Result was:\n$actualAnswer"
2130            puts [outputChannel] "---- Result should have been\
2131                    ($match matching):\n$result"
2132        }
2133    }
2134    if {$codeFailure} {
2135        switch -- $returnCode {
2136            0 { set msg "Test completed normally" }
2137            1 { set msg "Test generated error" }
2138            2 { set msg "Test generated return exception" }
2139            3 { set msg "Test generated break exception" }
2140            4 { set msg "Test generated continue exception" }
2141            default { set msg "Test generated exception" }
2142        }
2143        puts [outputChannel] "---- $msg; Return code was: $returnCode"
2144        puts [outputChannel] "---- Return code should have been\
2145                one of: $returnCodes"
2146        if {[IsVerbose error]} {
2147            if {[info exists errorInfo(body)] && ([lsearch $returnCodes 1]<0)} {
2148                puts [outputChannel] "---- errorInfo: $errorInfo(body)"
2149                puts [outputChannel] "---- errorCode: $errorCode(body)"
2150            }
2151        }
2152    }
2153    if {$outputFailure} {
2154        if {$outputCompare} {
2155            puts [outputChannel] "---- Error testing output: $outputMatch"
2156        } else {
2157            puts [outputChannel] "---- Output was:\n$outData"
2158            puts [outputChannel] "---- Output should have been\
2159                    ($match matching):\n$output"
2160        }
2161    }
2162    if {$errorFailure} {
2163        if {$errorCompare} {
2164            puts [outputChannel] "---- Error testing errorOutput: $errorMatch"
2165        } else {
2166            puts [outputChannel] "---- Error output was:\n$errData"
2167            puts [outputChannel] "---- Error output should have\
2168                    been ($match matching):\n$errorOutput"
2169        }
2170    }
2171    if {$cleanupFailure} {
2172        puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
2173        if {[info exists errorInfo(cleanup)]} {
2174            puts [outputChannel] "---- errorInfo(cleanup): $errorInfo(cleanup)"
2175            puts [outputChannel] "---- errorCode(cleanup): $errorCode(cleanup)"
2176        }
2177    }
2178    if {$coreFailure} {
2179        puts [outputChannel] "---- Core file produced while running\
2180                test!  $coreMsg"
2181    }
2182    puts [outputChannel] "==== $name FAILED\n"
2183
2184    incr testLevel -1
2185    return
2186}
2187
2188# Skipped --
2189#
2190# Given a test name and it constraints, returns a boolean indicating
2191# whether the current configuration says the test should be skipped.
2192#
2193# Side Effects:  Maintains tally of total tests seen and tests skipped.
2194#
2195proc tcltest::Skipped {name constraints} {
2196    variable testLevel
2197    variable numTests
2198    variable testConstraints
2199
2200    if {$testLevel == 1} {
2201        incr numTests(Total)
2202    }
2203    # skip the test if it's name matches an element of skip
2204    foreach pattern [skip] {
2205        if {[string match $pattern $name]} {
2206            if {$testLevel == 1} {
2207                incr numTests(Skipped)
2208                DebugDo 1 {AddToSkippedBecause userSpecifiedSkip}
2209            }
2210            return 1
2211        }
2212    }
2213    # skip the test if it's name doesn't match any element of match
2214    set ok 0
2215    foreach pattern [match] {
2216        if {[string match $pattern $name]} {
2217            set ok 1
2218            break
2219        }
2220    }
2221    if {!$ok} {
2222        if {$testLevel == 1} {
2223            incr numTests(Skipped)
2224            DebugDo 1 {AddToSkippedBecause userSpecifiedNonMatch}
2225        }
2226        return 1
2227    }
2228    if {[string equal {} $constraints]} {
2229        # If we're limited to the listed constraints and there aren't
2230        # any listed, then we shouldn't run the test.
2231        if {[limitConstraints]} {
2232            AddToSkippedBecause userSpecifiedLimitConstraint
2233            if {$testLevel == 1} {
2234                incr numTests(Skipped)
2235            }
2236            return 1
2237        }
2238    } else {
2239        # "constraints" argument exists;
2240        # make sure that the constraints are satisfied.
2241
2242        set doTest 0
2243        if {[string match {*[$\[]*} $constraints] != 0} {
2244            # full expression, e.g. {$foo > [info tclversion]}
2245            catch {set doTest [uplevel #0 expr $constraints]}
2246        } elseif {[regexp {[^.:_a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
2247            # something like {a || b} should be turned into
2248            # $testConstraints(a) || $testConstraints(b).
2249            regsub -all {[.\w]+} $constraints {$testConstraints(&)} c
2250            catch {set doTest [eval expr $c]}
2251        } elseif {![catch {llength $constraints}]} {
2252            # just simple constraints such as {unixOnly fonts}.
2253            set doTest 1
2254            foreach constraint $constraints {
2255                if {(![info exists testConstraints($constraint)]) \
2256                        || (!$testConstraints($constraint))} {
2257                    set doTest 0
2258
2259                    # store the constraint that kept the test from
2260                    # running
2261                    set constraints $constraint
2262                    break
2263                }
2264            }
2265        }
2266       
2267        if {!$doTest} {
2268            if {[IsVerbose skip]} {
2269                puts [outputChannel] "++++ $name SKIPPED: $constraints"
2270            }
2271
2272            if {$testLevel == 1} {
2273                incr numTests(Skipped)
2274                AddToSkippedBecause $constraints
2275            }
2276            return 1
2277        }
2278    }
2279    return 0
2280}
2281
2282# RunTest --
2283#
2284# This is where the body of a test is evaluated.  The combination of
2285# [RunTest] and [Eval] allows the output and error output of the test
2286# body to be captured for comparison against the expected values.
2287
2288proc tcltest::RunTest {name script} {
2289    DebugPuts 3 "Running $name {$script}"
2290
2291    # If there is no "memory" command (because memory debugging isn't
2292    # enabled), then don't attempt to use the command.
2293
2294    if {[llength [info commands memory]] == 1} {
2295        memory tag $name
2296    }
2297
2298    set code [catch {uplevel 1 $script} actualAnswer]
2299
2300    return [list $actualAnswer $code]
2301}
2302
2303#####################################################################
2304
2305# tcltest::cleanupTestsHook --
2306#
2307#       This hook allows a harness that builds upon tcltest to specify
2308#       additional things that should be done at cleanup.
2309#
2310
2311if {[llength [info commands tcltest::cleanupTestsHook]] == 0} {
2312    proc tcltest::cleanupTestsHook {} {}
2313}
2314
2315# tcltest::cleanupTests --
2316#
2317# Remove files and dirs created using the makeFile and makeDirectory
2318# commands since the last time this proc was invoked.
2319#
2320# Print the names of the files created without the makeFile command
2321# since the tests were invoked.
2322#
2323# Print the number tests (total, passed, failed, and skipped) since the
2324# tests were invoked.
2325#
2326# Restore original environment (as reported by special variable env).
2327#
2328# Arguments:
2329#      calledFromAllFile - if 0, behave as if we are running a single
2330#      test file within an entire suite of tests.  if we aren't running
2331#      a single test file, then don't report status.  check for new
2332#      files created during the test run and report on them.  if 1,
2333#      report collated status from all the test file runs.
2334#
2335# Results:
2336#      None.
2337#
2338# Side Effects:
2339#      None
2340#
2341
2342proc tcltest::cleanupTests {{calledFromAllFile 0}} {
2343    variable filesMade
2344    variable filesExisted
2345    variable createdNewFiles
2346    variable testSingleFile
2347    variable numTests
2348    variable numTestFiles
2349    variable failFiles
2350    variable skippedBecause
2351    variable currentFailure
2352    variable originalEnv
2353    variable originalTclPlatform
2354    variable coreModTime
2355
2356    FillFilesExisted
2357    set testFileName [file tail [info script]]
2358
2359    # Call the cleanup hook
2360    cleanupTestsHook
2361
2362    # Remove files and directories created by the makeFile and
2363    # makeDirectory procedures.  Record the names of files in
2364    # workingDirectory that were not pre-existing, and associate them
2365    # with the test file that created them.
2366
2367    if {!$calledFromAllFile} {
2368        foreach file $filesMade {
2369            if {[file exists $file]} {
2370                DebugDo 1 {Warn "cleanupTests deleting $file..."}
2371                catch {file delete -force $file}
2372            }
2373        }
2374        set currentFiles {}
2375        foreach file [glob -nocomplain \
2376                -directory [temporaryDirectory] *] {
2377            lappend currentFiles [file tail $file]
2378        }
2379        set newFiles {}
2380        foreach file $currentFiles {
2381            if {[lsearch -exact $filesExisted $file] == -1} {
2382                lappend newFiles $file
2383            }
2384        }
2385        set filesExisted $currentFiles
2386        if {[llength $newFiles] > 0} {
2387            set createdNewFiles($testFileName) $newFiles
2388        }
2389    }
2390
2391    if {$calledFromAllFile || $testSingleFile} {
2392
2393        # print stats
2394
2395        puts -nonewline [outputChannel] "$testFileName:"
2396        foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2397            puts -nonewline [outputChannel] \
2398                    "\t$index\t$numTests($index)"
2399        }
2400        puts [outputChannel] ""
2401
2402        # print number test files sourced
2403        # print names of files that ran tests which failed
2404
2405        if {$calledFromAllFile} {
2406            puts [outputChannel] \
2407                    "Sourced $numTestFiles Test Files."
2408            set numTestFiles 0
2409            if {[llength $failFiles] > 0} {
2410                puts [outputChannel] \
2411                        "Files with failing tests: $failFiles"
2412                set failFiles {}
2413            }
2414        }
2415
2416        # if any tests were skipped, print the constraints that kept
2417        # them from running.
2418
2419        set constraintList [array names skippedBecause]
2420        if {[llength $constraintList] > 0} {
2421            puts [outputChannel] \
2422                    "Number of tests skipped for each constraint:"
2423            foreach constraint [lsort $constraintList] {
2424                puts [outputChannel] \
2425                        "\t$skippedBecause($constraint)\t$constraint"
2426                unset skippedBecause($constraint)
2427            }
2428        }
2429
2430        # report the names of test files in createdNewFiles, and reset
2431        # the array to be empty.
2432
2433        set testFilesThatTurded [lsort [array names createdNewFiles]]
2434        if {[llength $testFilesThatTurded] > 0} {
2435            puts [outputChannel] "Warning: files left behind:"
2436            foreach testFile $testFilesThatTurded {
2437                puts [outputChannel] \
2438                        "\t$testFile:\t$createdNewFiles($testFile)"
2439                unset createdNewFiles($testFile)
2440            }
2441        }
2442
2443        # reset filesMade, filesExisted, and numTests
2444
2445        set filesMade {}
2446        foreach index [list "Total" "Passed" "Skipped" "Failed"] {
2447            set numTests($index) 0
2448        }
2449
2450        # exit only if running Tk in non-interactive mode
2451        # This should be changed to determine if an event
2452        # loop is running, which is the real issue.
2453        # Actually, this doesn't belong here at all.  A package
2454        # really has no business [exit]-ing an application.
2455        if {![catch {package present Tk}] && ![testConstraint interactive]} {
2456            exit
2457        }
2458    } else {
2459
2460        # if we're deferring stat-reporting until all files are sourced,
2461        # then add current file to failFile list if any tests in this
2462        # file failed
2463
2464        if {$currentFailure \
2465                && ([lsearch -exact $failFiles $testFileName] == -1)} {
2466            lappend failFiles $testFileName
2467        }
2468        set currentFailure false
2469
2470        # restore the environment to the state it was in before this package
2471        # was loaded
2472
2473        set newEnv {}
2474        set changedEnv {}
2475        set removedEnv {}
2476        foreach index [array names ::env] {
2477            if {![info exists originalEnv($index)]} {
2478                lappend newEnv $index
2479                unset ::env($index)
2480            } else {
2481                if {$::env($index) != $originalEnv($index)} {
2482                    lappend changedEnv $index
2483                    set ::env($index) $originalEnv($index)
2484                }
2485            }
2486        }
2487        foreach index [array names originalEnv] {
2488            if {![info exists ::env($index)]} {
2489                lappend removedEnv $index
2490                set ::env($index) $originalEnv($index)
2491            }
2492        }
2493        if {[llength $newEnv] > 0} {
2494            puts [outputChannel] \
2495                    "env array elements created:\t$newEnv"
2496        }
2497        if {[llength $changedEnv] > 0} {
2498            puts [outputChannel] \
2499                    "env array elements changed:\t$changedEnv"
2500        }
2501        if {[llength $removedEnv] > 0} {
2502            puts [outputChannel] \
2503                    "env array elements removed:\t$removedEnv"
2504        }
2505
2506        set changedTclPlatform {}
2507        foreach index [array names originalTclPlatform] {
2508            if {$::tcl_platform($index) \
2509                    != $originalTclPlatform($index)} {
2510                lappend changedTclPlatform $index
2511                set ::tcl_platform($index) $originalTclPlatform($index)
2512            }
2513        }
2514        if {[llength $changedTclPlatform] > 0} {
2515            puts [outputChannel] "tcl_platform array elements\
2516                    changed:\t$changedTclPlatform"
2517        }
2518
2519        if {[file exists [file join [workingDirectory] core]]} {
2520            if {[preserveCore] > 1} {
2521                puts "rename core file (> 1)"
2522                puts [outputChannel] "produced core file! \
2523                        Moving file to: \
2524                        [file join [temporaryDirectory] core-$testFileName]"
2525                catch {file rename -force \
2526                        [file join [workingDirectory] core] \
2527                        [file join [temporaryDirectory] core-$testFileName]
2528                } msg
2529                if {[string length $msg] > 0} {
2530                    PrintError "Problem renaming file: $msg"
2531                }
2532            } else {
2533                # Print a message if there is a core file and (1) there
2534                # previously wasn't one or (2) the new one is different
2535                # from the old one.
2536
2537                if {[info exists coreModTime]} {
2538                    if {$coreModTime != [file mtime \
2539                            [file join [workingDirectory] core]]} {
2540                        puts [outputChannel] "A core file was created!"
2541                    }
2542                } else {
2543                    puts [outputChannel] "A core file was created!"
2544                }
2545            }
2546        }
2547    }
2548    flush [outputChannel]
2549    flush [errorChannel]
2550    return
2551}
2552
2553#####################################################################
2554
2555# Procs that determine which tests/test files to run
2556
2557# tcltest::GetMatchingFiles
2558#
2559#       Looks at the patterns given to match and skip files and uses
2560#       them to put together a list of the tests that will be run.
2561#
2562# Arguments:
2563#       directory to search
2564#
2565# Results:
2566#       The constructed list is returned to the user.  This will
2567#       primarily be used in 'all.tcl' files.  It is used in
2568#       runAllTests.
2569#
2570# Side Effects:
2571#       None
2572
2573# a lower case version is needed for compatibility with tcltest 1.0
2574proc tcltest::getMatchingFiles args {eval GetMatchingFiles $args}
2575
2576proc tcltest::GetMatchingFiles { args } {
2577    if {[llength $args]} {
2578        set dirList $args
2579    } else {
2580        # Finding tests only in [testsDirectory] is normal operation.
2581        # This procedure is written to accept multiple directory arguments
2582        # only to satisfy version 1 compatibility.
2583        set dirList [list [testsDirectory]]
2584    }
2585
2586    set matchingFiles [list]
2587    foreach directory $dirList {
2588
2589        # List files in $directory that match patterns to run.
2590        set matchFileList [list]
2591        foreach match [matchFiles] {
2592            set matchFileList [concat $matchFileList \
2593                    [glob -directory $directory -types {b c f p s} \
2594                    -nocomplain -- $match]]
2595        }
2596
2597        # List files in $directory that match patterns to skip.
2598        set skipFileList [list]
2599        foreach skip [skipFiles] {
2600            set skipFileList [concat $skipFileList \
2601                    [glob -directory $directory -types {b c f p s} \
2602                    -nocomplain -- $skip]]
2603        }
2604
2605        # Add to result list all files in match list and not in skip list
2606        foreach file $matchFileList {
2607            if {[lsearch -exact $skipFileList $file] == -1} {
2608                lappend matchingFiles $file
2609            }
2610        }
2611    }
2612
2613    if {[llength $matchingFiles] == 0} {
2614        PrintError "No test files remain after applying your match and\
2615                skip patterns!"
2616    }
2617    return $matchingFiles
2618}
2619
2620# tcltest::GetMatchingDirectories --
2621#
2622#       Looks at the patterns given to match and skip directories and
2623#       uses them to put together a list of the test directories that we
2624#       should attempt to run.  (Only subdirectories containing an
2625#       "all.tcl" file are put into the list.)
2626#
2627# Arguments:
2628#       root directory from which to search
2629#
2630# Results:
2631#       The constructed list is returned to the user.  This is used in
2632#       the primary all.tcl file.
2633#
2634# Side Effects:
2635#       None.
2636
2637proc tcltest::GetMatchingDirectories {rootdir} {
2638
2639    # Determine the skip list first, to avoid [glob]-ing over subdirectories
2640    # we're going to throw away anyway.  Be sure we skip the $rootdir if it
2641    # comes up to avoid infinite loops.
2642    set skipDirs [list $rootdir]
2643    foreach pattern [skipDirectories] {
2644        set skipDirs [concat $skipDirs [glob -directory $rootdir -types d \
2645                -nocomplain -- $pattern]]
2646    }
2647
2648    # Now step through the matching directories, prune out the skipped ones
2649    # as you go.
2650    set matchDirs [list]
2651    foreach pattern [matchDirectories] {
2652        foreach path [glob -directory $rootdir -types d -nocomplain -- \
2653                $pattern] {
2654            if {[lsearch -exact $skipDirs $path] == -1} {
2655                set matchDirs [concat $matchDirs [GetMatchingDirectories $path]]
2656                if {[file exists [file join $path all.tcl]]} {
2657                    lappend matchDirs $path
2658                }
2659            }
2660        }
2661    }
2662
2663    if {[llength $matchDirs] == 0} {
2664        DebugPuts 1 "No test directories remain after applying match\
2665                and skip patterns!"
2666    }
2667    return $matchDirs
2668}
2669
2670# tcltest::runAllTests --
2671#
2672#       prints output and sources test files according to the match and
2673#       skip patterns provided.  after sourcing test files, it goes on
2674#       to source all.tcl files in matching test subdirectories.
2675#
2676# Arguments:
2677#       shell being tested
2678#
2679# Results:
2680#       None.
2681#
2682# Side effects:
2683#       None.
2684
2685proc tcltest::runAllTests { {shell ""} } {
2686    variable testSingleFile
2687    variable numTestFiles
2688    variable numTests
2689    variable failFiles
2690
2691    FillFilesExisted
2692    if {[llength [info level 0]] == 1} {
2693        set shell [interpreter]
2694    }
2695
2696    set testSingleFile false
2697
2698    puts [outputChannel] "Tests running in interp:  $shell"
2699    puts [outputChannel] "Tests located in:  [testsDirectory]"
2700    puts [outputChannel] "Tests running in:  [workingDirectory]"
2701    puts [outputChannel] "Temporary files stored in\
2702            [temporaryDirectory]"
2703
2704    # [file system] first available in Tcl 8.4
2705    if {![catch {file system [testsDirectory]} result]
2706            && ![string equal native [lindex $result 0]]} {
2707        # If we aren't running in the native filesystem, then we must
2708        # run the tests in a single process (via 'source'), because
2709        # trying to run then via a pipe will fail since the files don't
2710        # really exist.
2711        singleProcess 1
2712    }
2713
2714    if {[singleProcess]} {
2715        puts [outputChannel] \
2716                "Test files sourced into current interpreter"
2717    } else {
2718        puts [outputChannel] \
2719                "Test files run in separate interpreters"
2720    }
2721    if {[llength [skip]] > 0} {
2722        puts [outputChannel] "Skipping tests that match:  [skip]"
2723    }
2724    puts [outputChannel] "Running tests that match:  [match]"
2725
2726    if {[llength [skipFiles]] > 0} {
2727        puts [outputChannel] \
2728                "Skipping test files that match:  [skipFiles]"
2729    }
2730    if {[llength [matchFiles]] > 0} {
2731        puts [outputChannel] \
2732                "Only running test files that match:  [matchFiles]"
2733    }
2734
2735    set timeCmd {clock format [clock seconds]}
2736    puts [outputChannel] "Tests began at [eval $timeCmd]"
2737
2738    # Run each of the specified tests
2739    foreach file [lsort [GetMatchingFiles]] {
2740        set tail [file tail $file]
2741        puts [outputChannel] $tail
2742        flush [outputChannel]
2743
2744        if {[singleProcess]} {
2745            incr numTestFiles
2746            uplevel 1 [list ::source $file]
2747        } else {
2748            # Pass along our configuration to the child processes.
2749            # EXCEPT for the -outfile, because the parent process
2750            # needs to read and process output of children.
2751            set childargv [list]
2752            foreach opt [Configure] {
2753                if {[string equal $opt -outfile]} {continue}
2754                lappend childargv $opt [Configure $opt]
2755            }
2756            set cmd [linsert $childargv 0 | $shell $file]
2757            if {[catch {
2758                incr numTestFiles
2759                set pipeFd [open $cmd "r"]
2760                while {[gets $pipeFd line] >= 0} {
2761                    if {[regexp [join {
2762                            {^([^:]+):\t}
2763                            {Total\t([0-9]+)\t}
2764                            {Passed\t([0-9]+)\t}
2765                            {Skipped\t([0-9]+)\t}
2766                            {Failed\t([0-9]+)}
2767                            } ""] $line null testFile \
2768                            Total Passed Skipped Failed]} {
2769                        foreach index {Total Passed Skipped Failed} {
2770                            incr numTests($index) [set $index]
2771                        }
2772                        if {$Failed > 0} {
2773                            lappend failFiles $testFile
2774                        }
2775                    } elseif {[regexp [join {
2776                            {^Number of tests skipped }
2777                            {for each constraint:}
2778                            {|^\t(\d+)\t(.+)$}
2779                            } ""] $line match skipped constraint]} {
2780                        if {[string match \t* $match]} {
2781                            AddToSkippedBecause $constraint $skipped
2782                        }
2783                    } else {
2784                        puts [outputChannel] $line
2785                    }
2786                }
2787                close $pipeFd
2788            } msg]} {
2789                puts [outputChannel] "Test file error: $msg"
2790                # append the name of the test to a list to be reported
2791                # later
2792                lappend testFileFailures $file
2793            }
2794        }
2795    }
2796
2797    # cleanup
2798    puts [outputChannel] "\nTests ended at [eval $timeCmd]"
2799    cleanupTests 1
2800    if {[info exists testFileFailures]} {
2801        puts [outputChannel] "\nTest files exiting with errors:  \n"
2802        foreach file $testFileFailures {
2803            puts [outputChannel] "  [file tail $file]\n"
2804        }
2805    }
2806
2807    # Checking for subdirectories in which to run tests
2808    foreach directory [GetMatchingDirectories [testsDirectory]] {
2809        set dir [file tail $directory]
2810        puts [outputChannel] [string repeat ~ 44]
2811        puts [outputChannel] "$dir test began at [eval $timeCmd]\n"
2812       
2813        uplevel 1 [list ::source [file join $directory all.tcl]]
2814       
2815        set endTime [eval $timeCmd]
2816        puts [outputChannel] "\n$dir test ended at $endTime"
2817        puts [outputChannel] ""
2818        puts [outputChannel] [string repeat ~ 44]
2819    }
2820    return
2821}
2822
2823#####################################################################
2824
2825# Test utility procs - not used in tcltest, but may be useful for
2826# testing.
2827
2828# tcltest::loadTestedCommands --
2829#
2830#     Uses the specified script to load the commands to test. Allowed to
2831#     be empty, as the tested commands could have been compiled into the
2832#     interpreter.
2833#
2834# Arguments
2835#     none
2836#
2837# Results
2838#     none
2839#
2840# Side Effects:
2841#     none.
2842
2843proc tcltest::loadTestedCommands {} {
2844    variable l
2845    if {[string equal {} [loadScript]]} {
2846        return
2847    }
2848
2849    return [uplevel 1 [loadScript]]
2850}
2851
2852# tcltest::saveState --
2853#
2854#       Save information regarding what procs and variables exist.
2855#
2856# Arguments:
2857#       none
2858#
2859# Results:
2860#       Modifies the variable saveState
2861#
2862# Side effects:
2863#       None.
2864
2865proc tcltest::saveState {} {
2866    variable saveState
2867    uplevel 1 [list ::set [namespace which -variable saveState]] \
2868            {[::list [::info procs] [::info vars]]}
2869    DebugPuts  2 "[lindex [info level 0] 0]: $saveState"
2870    return
2871}
2872
2873# tcltest::restoreState --
2874#
2875#       Remove procs and variables that didn't exist before the call to
2876#       [saveState].
2877#
2878# Arguments:
2879#       none
2880#
2881# Results:
2882#       Removes procs and variables from your environment if they don't
2883#       exist in the saveState variable.
2884#
2885# Side effects:
2886#       None.
2887
2888proc tcltest::restoreState {} {
2889    variable saveState
2890    foreach p [uplevel 1 {::info procs}] {
2891        if {([lsearch [lindex $saveState 0] $p] < 0)
2892                && ![string equal [namespace current]::$p \
2893                [uplevel 1 [list ::namespace origin $p]]]} {
2894
2895            DebugPuts 2 "[lindex [info level 0] 0]: Removing proc $p"
2896            uplevel 1 [list ::catch [list ::rename $p {}]]
2897        }
2898    }
2899    foreach p [uplevel 1 {::info vars}] {
2900        if {[lsearch [lindex $saveState 1] $p] < 0} {
2901            DebugPuts 2 "[lindex [info level 0] 0]:\
2902                    Removing variable $p"
2903            uplevel 1 [list ::catch [list ::unset $p]]
2904        }
2905    }
2906    return
2907}
2908
2909# tcltest::normalizeMsg --
2910#
2911#       Removes "extra" newlines from a string.
2912#
2913# Arguments:
2914#       msg        String to be modified
2915#
2916# Results:
2917#       string with extra newlines removed
2918#
2919# Side effects:
2920#       None.
2921
2922proc tcltest::normalizeMsg {msg} {
2923    regsub "\n$" [string tolower $msg] "" msg
2924    set msg [string map [list "\n\n" "\n"] $msg]
2925    return [string map [list "\n\}" "\}"] $msg]
2926}
2927
2928# tcltest::makeFile --
2929#
2930# Create a new file with the name <name>, and write <contents> to it.
2931#
2932# If this file hasn't been created via makeFile since the last time
2933# cleanupTests was called, add it to the $filesMade list, so it will be
2934# removed by the next call to cleanupTests.
2935#
2936# Arguments:
2937#       contents        content of the new file
2938#       name            name of the new file
2939#       directory       directory name for new file
2940#
2941# Results:
2942#       absolute path to the file created
2943#
2944# Side effects:
2945#       None.
2946
2947proc tcltest::makeFile {contents name {directory ""}} {
2948    variable filesMade
2949    FillFilesExisted
2950
2951    if {[llength [info level 0]] == 3} {
2952        set directory [temporaryDirectory]
2953    }
2954
2955    set fullName [file join $directory $name]
2956
2957    DebugPuts 3 "[lindex [info level 0] 0]:\
2958             putting ``$contents'' into $fullName"
2959
2960    set fd [open $fullName w]
2961    fconfigure $fd -translation lf
2962    if {[string equal [string index $contents end] \n]} {
2963        puts -nonewline $fd $contents
2964    } else {
2965        puts $fd $contents
2966    }
2967    close $fd
2968
2969    if {[lsearch -exact $filesMade $fullName] == -1} {
2970        lappend filesMade $fullName
2971    }
2972    return $fullName
2973}
2974
2975# tcltest::removeFile --
2976#
2977#       Removes the named file from the filesystem
2978#
2979# Arguments:
2980#       name          file to be removed
2981#       directory     directory from which to remove file
2982#
2983# Results:
2984#       return value from [file delete]
2985#
2986# Side effects:
2987#       None.
2988
2989proc tcltest::removeFile {name {directory ""}} {
2990    variable filesMade
2991    FillFilesExisted
2992    if {[llength [info level 0]] == 2} {
2993        set directory [temporaryDirectory]
2994    }
2995    set fullName [file join $directory $name]
2996    DebugPuts 3 "[lindex [info level 0] 0]: removing $fullName"
2997    set idx [lsearch -exact $filesMade $fullName]
2998    set filesMade [lreplace $filesMade $idx $idx]
2999    if {$idx == -1} {
3000        DebugDo 1 {
3001            Warn "removeFile removing \"$fullName\":\n  not created by makeFile"
3002        }
3003    } 
3004    if {![file isfile $fullName]} {
3005        DebugDo 1 {
3006            Warn "removeFile removing \"$fullName\":\n  not a file"
3007        }
3008    }
3009    return [file delete $fullName]
3010}
3011
3012# tcltest::makeDirectory --
3013#
3014# Create a new dir with the name <name>.
3015#
3016# If this dir hasn't been created via makeDirectory since the last time
3017# cleanupTests was called, add it to the $directoriesMade list, so it
3018# will be removed by the next call to cleanupTests.
3019#
3020# Arguments:
3021#       name            name of the new directory
3022#       directory       directory in which to create new dir
3023#
3024# Results:
3025#       absolute path to the directory created
3026#
3027# Side effects:
3028#       None.
3029
3030proc tcltest::makeDirectory {name {directory ""}} {
3031    variable filesMade
3032    FillFilesExisted
3033    if {[llength [info level 0]] == 2} {
3034        set directory [temporaryDirectory]
3035    }
3036    set fullName [file join $directory $name]
3037    DebugPuts 3 "[lindex [info level 0] 0]: creating $fullName"
3038    file mkdir $fullName
3039    if {[lsearch -exact $filesMade $fullName] == -1} {
3040        lappend filesMade $fullName
3041    }
3042    return $fullName
3043}
3044
3045# tcltest::removeDirectory --
3046#
3047#       Removes a named directory from the file system.
3048#
3049# Arguments:
3050#       name          Name of the directory to remove
3051#       directory     Directory from which to remove
3052#
3053# Results:
3054#       return value from [file delete]
3055#
3056# Side effects:
3057#       None
3058
3059proc tcltest::removeDirectory {name {directory ""}} {
3060    variable filesMade
3061    FillFilesExisted
3062    if {[llength [info level 0]] == 2} {
3063        set directory [temporaryDirectory]
3064    }
3065    set fullName [file join $directory $name]
3066    DebugPuts 3 "[lindex [info level 0] 0]: deleting $fullName"
3067    set idx [lsearch -exact $filesMade $fullName]
3068    set filesMade [lreplace $filesMade $idx $idx]
3069    if {$idx == -1} {
3070        DebugDo 1 {
3071            Warn "removeDirectory removing \"$fullName\":\n  not created\
3072                    by makeDirectory"
3073        }
3074    } 
3075    if {![file isdirectory $fullName]} {
3076        DebugDo 1 {
3077            Warn "removeDirectory removing \"$fullName\":\n  not a directory"
3078        }
3079    }
3080    return [file delete -force $fullName]
3081}
3082
3083# tcltest::viewFile --
3084#
3085#       reads the content of a file and returns it
3086#
3087# Arguments:
3088#       name of the file to read
3089#       directory in which file is located
3090#
3091# Results:
3092#       content of the named file
3093#
3094# Side effects:
3095#       None.
3096
3097proc tcltest::viewFile {name {directory ""}} {
3098    FillFilesExisted
3099    if {[llength [info level 0]] == 2} {
3100        set directory [temporaryDirectory]
3101    }
3102    set fullName [file join $directory $name]
3103    set f [open $fullName]
3104    set data [read -nonewline $f]
3105    close $f
3106    return $data
3107}
3108
3109# tcltest::bytestring --
3110#
3111# Construct a string that consists of the requested sequence of bytes,
3112# as opposed to a string of properly formed UTF-8 characters.
3113# This allows the tester to
3114# 1. Create denormalized or improperly formed strings to pass to C
3115#    procedures that are supposed to accept strings with embedded NULL
3116#    bytes.
3117# 2. Confirm that a string result has a certain pattern of bytes, for
3118#    instance to confirm that "\xe0\0" in a Tcl script is stored
3119#    internally in UTF-8 as the sequence of bytes "\xc3\xa0\xc0\x80".
3120#
3121# Generally, it's a bad idea to examine the bytes in a Tcl string or to
3122# construct improperly formed strings in this manner, because it involves
3123# exposing that Tcl uses UTF-8 internally.
3124#
3125# Arguments:
3126#       string being converted
3127#
3128# Results:
3129#       result fom encoding
3130#
3131# Side effects:
3132#       None
3133
3134proc tcltest::bytestring {string} {
3135    return [encoding convertfrom identity $string]
3136}
3137
3138# tcltest::OpenFiles --
3139#
3140#       used in io tests, uses testchannel
3141#
3142# Arguments:
3143#       None.
3144#
3145# Results:
3146#       ???
3147#
3148# Side effects:
3149#       None.
3150
3151proc tcltest::OpenFiles {} {
3152    if {[catch {testchannel open} result]} {
3153        return {}
3154    }
3155    return $result
3156}
3157
3158# tcltest::LeakFiles --
3159#
3160#       used in io tests, uses testchannel
3161#
3162# Arguments:
3163#       None.
3164#
3165# Results:
3166#       ???
3167#
3168# Side effects:
3169#       None.
3170
3171proc tcltest::LeakFiles {old} {
3172    if {[catch {testchannel open} new]} {
3173        return {}
3174    }
3175    set leak {}
3176    foreach p $new {
3177        if {[lsearch $old $p] < 0} {
3178            lappend leak $p
3179        }
3180    }
3181    return $leak
3182}
3183
3184#
3185# Internationalization / ISO support procs     -- dl
3186#
3187
3188# tcltest::SetIso8859_1_Locale --
3189#
3190#       used in cmdIL.test, uses testlocale
3191#
3192# Arguments:
3193#       None.
3194#
3195# Results:
3196#       None.
3197#
3198# Side effects:
3199#       None.
3200
3201proc tcltest::SetIso8859_1_Locale {} {
3202    variable previousLocale
3203    variable isoLocale
3204    if {[info commands testlocale] != ""} {
3205        set previousLocale [testlocale ctype]
3206        testlocale ctype $isoLocale
3207    }
3208    return
3209}
3210
3211# tcltest::RestoreLocale --
3212#
3213#       used in cmdIL.test, uses testlocale
3214#
3215# Arguments:
3216#       None.
3217#
3218# Results:
3219#       None.
3220#
3221# Side effects:
3222#       None.
3223
3224proc tcltest::RestoreLocale {} {
3225    variable previousLocale
3226    if {[info commands testlocale] != ""} {
3227        testlocale ctype $previousLocale
3228    }
3229    return
3230}
3231
3232# tcltest::threadReap --
3233#
3234#       Kill all threads except for the main thread.
3235#       Do nothing if testthread is not defined.
3236#
3237# Arguments:
3238#       none.
3239#
3240# Results:
3241#       Returns the number of existing threads.
3242#
3243# Side Effects:
3244#       none.
3245#
3246
3247proc tcltest::threadReap {} {
3248    if {[info commands testthread] != {}} {
3249
3250        # testthread built into tcltest
3251
3252        testthread errorproc ThreadNullError
3253        while {[llength [testthread names]] > 1} {
3254            foreach tid [testthread names] {
3255                if {$tid != [mainThread]} {
3256                    catch {
3257                        testthread send -async $tid {testthread exit}
3258                    }
3259                }
3260            }
3261            ## Enter a bit a sleep to give the threads enough breathing
3262            ## room to kill themselves off, otherwise the end up with a
3263            ## massive queue of repeated events
3264            after 1
3265        }
3266        testthread errorproc ThreadError
3267        return [llength [testthread names]]
3268    } elseif {[info commands thread::id] != {}} {
3269       
3270        # Thread extension
3271
3272        thread::errorproc ThreadNullError
3273        while {[llength [thread::names]] > 1} {
3274            foreach tid [thread::names] {
3275                if {$tid != [mainThread]} {
3276                    catch {thread::send -async $tid {thread::exit}}
3277                }
3278            }
3279            ## Enter a bit a sleep to give the threads enough breathing
3280            ## room to kill themselves off, otherwise the end up with a
3281            ## massive queue of repeated events
3282            after 1
3283        }
3284        thread::errorproc ThreadError
3285        return [llength [thread::names]]
3286    } else {
3287        return 1
3288    }
3289    return 0
3290}
3291
3292# Initialize the constraints and set up command line arguments
3293namespace eval tcltest {
3294    # Define initializers for all the built-in contraint definitions
3295    DefineConstraintInitializers
3296
3297    # Set up the constraints in the testConstraints array to be lazily
3298    # initialized by a registered initializer, or by "false" if no
3299    # initializer is registered.
3300    trace variable testConstraints r [namespace code SafeFetch]
3301
3302    # Only initialize constraints at package load time if an
3303    # [initConstraintsHook] has been pre-defined.  This is only
3304    # for compatibility support.  The modern way to add a custom
3305    # test constraint is to just call the [testConstraint] command
3306    # straight away, without all this "hook" nonsense.
3307    if {[string equal [namespace current] \
3308            [namespace qualifiers [namespace which initConstraintsHook]]]} {
3309        InitConstraints
3310    } else {
3311        proc initConstraintsHook {} {}
3312    }
3313
3314    # Define the standard match commands
3315    customMatch exact   [list string equal]
3316    customMatch glob    [list string match]
3317    customMatch regexp  [list regexp --]
3318
3319    # If the TCLTEST_OPTIONS environment variable exists, configure
3320    # tcltest according to the option values it specifies.  This has
3321    # the effect of resetting tcltest's default configuration.
3322    proc ConfigureFromEnvironment {} {
3323        upvar #0 env(TCLTEST_OPTIONS) options
3324        if {[catch {llength $options} msg]} {
3325            Warn "invalid TCLTEST_OPTIONS \"$options\":\n  invalid\
3326                    Tcl list: $msg"
3327            return
3328        }
3329        if {[llength $::env(TCLTEST_OPTIONS)] % 2} {
3330            Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  should be\
3331                    -option value ?-option value ...?"
3332            return
3333        }
3334        if {[catch {eval Configure $::env(TCLTEST_OPTIONS)} msg]} {
3335            Warn "invalid TCLTEST_OPTIONS: \"$options\":\n  $msg"
3336            return
3337        }
3338    }
3339    if {[info exists ::env(TCLTEST_OPTIONS)]} {
3340        ConfigureFromEnvironment
3341    }
3342
3343    proc LoadTimeCmdLineArgParsingRequired {} {
3344        set required false
3345        if {[info exists ::argv] && [lsearch -exact $::argv -help] != -1} {
3346            # The command line asks for -help, so give it (and exit)
3347            # right now.  ([configure] does not process -help)
3348            set required true
3349        }
3350        foreach hook { PrintUsageInfoHook processCmdLineArgsHook
3351                        processCmdLineArgsAddFlagsHook } {
3352            if {[string equal [namespace current] [namespace qualifiers \
3353                    [namespace which $hook]]]} {
3354                set required true
3355            } else {
3356                proc $hook args {}
3357            }
3358        }
3359        return $required
3360    }
3361
3362    # Only initialize configurable options from the command line arguments
3363    # at package load time if necessary for backward compatibility.  This
3364    # lets the tcltest user call [configure] for themselves if they wish.
3365    # Traces are established for auto-configuration from the command line
3366    # if any configurable options are accessed before the user calls
3367    # [configure].
3368    if {[LoadTimeCmdLineArgParsingRequired]} {
3369        ProcessCmdLineArgs
3370    } else {
3371        EstablishAutoConfigureTraces
3372    }
3373
3374    package provide [namespace tail [namespace current]] $Version
3375}
Note: See TracBrowser for help on using the repository browser.