Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/tests/tcltest.test @ 47

Last change on this file since 47 was 25, checked in by landauf, 17 years ago

added tcl to libs
File size: 49.7 KB
Line 
1# This file contains a collection of tests for one or more of the Tcl
2# built-in commands.  Sourcing this file into Tcl runs the tests and
3# generates output for errors.  No output means no errors were found.
4#
5# Copyright (c) 1998-1999 by Scriptics Corporation.
6# Copyright (c) 2000 by Ajuba Solutions
7# All rights reserved.
8#
9# RCS: @(#) $Id: tcltest.test,v 1.55 2007/01/18 22:09:44 dkf Exp $
10
11# Note that there are several places where the value of
12# tcltest::currentFailure is stored/reset in the -setup/-cleanup
13# of a test that has a body that runs [test] that will fail.
14# This is a workaround of using the same tcltest code that we are
15# testing to run the test itself.  Ditto on things like [verbose].
16#
17# It would be better to have the -body of the tests run the tcltest
18# commands in a slave interp so the [test] being tested would not
19# interfere with the [test] doing the testing.
20#
21
22if {[catch {package require tcltest 2.1}]} {
23    puts stderr "Skipping tests in [info script].  tcltest 2.1 required."
24    return
25}
26
27namespace eval ::tcltest::test {
28
29namespace import ::tcltest::*
30
31makeFile {
32    package require tcltest
33    namespace import ::tcltest::test
34    test a-1.0 {test a} {
35        list 0
36    } {0}
37    test b-1.0 {test b} {
38        list 1
39    } {0}
40    test c-1.0 {test c} {knownBug} {
41    } {}
42    test d-1.0 {test d} {
43        error "foo" foo 9
44    } {}
45    tcltest::cleanupTests
46    exit
47} test.tcl
48
49cd [temporaryDirectory]
50testConstraint exec [llength [info commands exec]]
51# test -help
52# Child processes because -help [exit]s.
53test tcltest-1.1 {tcltest -help} {exec} {
54    set result [catch {exec [interpreter] test.tcl -help} msg]
55    list $result [regexp Usage $msg]
56} {1 1}
57test tcltest-1.2 {tcltest -help -something} {exec} {
58    set result [catch {exec [interpreter] test.tcl -help -something} msg]
59    list $result [regexp Usage $msg]
60} {1 1}
61test tcltest-1.3 {tcltest -h} {exec} {
62    set result [catch {exec [interpreter] test.tcl -h} msg]
63    list $result [regexp Usage $msg]
64} {1 0}
65
66# -verbose, implicit & explicit testing of [verbose]
67proc slave {msgVar args} {
68    upvar 1 $msgVar msg
69
70    interp create [namespace current]::i
71    # Fake the slave interp into dumping output to a file
72    i eval {namespace eval ::tcltest {}}
73    i eval "set tcltest::outputChannel\
74            \[[list open [set of [makeFile {} output]] w]]"
75    i eval "set tcltest::errorChannel\
76            \[[list open [set ef [makeFile {} error]] w]]"
77    i eval [list set argv0 [lindex $args 0]]
78    i eval [list set argv [lrange $args 1 end]]
79    i eval [list package ifneeded tcltest [package provide tcltest] \
80            [package ifneeded tcltest [package provide tcltest]]]
81    i eval {proc exit args {}}
82
83    # Need to capture output in msg
84
85    set code [catch {i eval {source $argv0}} foo]
86if $code {
87#puts "$code: $foo\n$::errorInfo"
88}
89    i eval {close $tcltest::outputChannel}
90    interp delete [namespace current]::i
91    set f [open $of]
92    set msg [read -nonewline $f]
93    close $f
94    set f [open $ef]
95    set err [read -nonewline $f]
96    close $f
97    removeFile output
98    removeFile error
99    if {[string length $err]} {
100        set code 1
101        append msg \n$err
102    }
103    return $code
104
105#    return [catch {uplevel 1 [linsert $args 0  exec [interpreter]]} msg]
106}
107test tcltest-2.0 {tcltest (verbose default - 'b')} {unixOrPc} {
108    set result [slave msg test.tcl]
109    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
110            [regexp c-1.0 $msg] \
111            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
112} {0 1 0 0 1}
113test tcltest-2.1 {tcltest -verbose 'b'} {unixOrPc} {
114    set result [slave msg test.tcl -verbose 'b']
115    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
116            [regexp c-1.0 $msg] \
117            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
118} {0 1 0 0 1}
119test tcltest-2.2 {tcltest -verbose 'p'} {unixOrPc} {
120    set result [slave msg test.tcl -verbose 'p']
121    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
122            [regexp c-1.0 $msg] \
123            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
124} {0 0 1 0 1}
125test tcltest-2.3 {tcltest -verbose 's'} {unixOrPc} {
126    set result [slave msg test.tcl -verbose 's']
127    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
128            [regexp c-1.0 $msg] \
129            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
130} {0 0 0 1 1}
131test tcltest-2.4 {tcltest -verbose 'ps'} {unixOrPc} {
132    set result [slave msg test.tcl -verbose 'ps']
133    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
134            [regexp c-1.0 $msg] \
135            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
136} {0 0 1 1 1}
137test tcltest-2.5 {tcltest -verbose 'psb'} {unixOrPc} {
138    set result [slave msg test.tcl -verbose 'psb']
139    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
140            [regexp c-1.0 $msg] \
141            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
142} {0 1 1 1 1}
143
144test tcltest-2.5a {tcltest -verbose 'pass skip body'} {unixOrPc} {
145    set result [slave msg test.tcl -verbose "pass skip body"]
146    list $result [regexp "Contents of test case" $msg] [regexp a-1.0 $msg] \
147            [regexp c-1.0 $msg] \
148            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
149} {0 1 1 1 1}
150
151test tcltest-2.6 {tcltest -verbose 't'}  {
152    -constraints {unixOrPc}
153    -body {
154        set result [slave msg test.tcl -verbose 't']
155        list $result $msg
156    }
157    -result {^0 .*a-1.0 start.*b-1.0 start}
158    -match regexp
159}
160
161test tcltest-2.6a {tcltest -verbose 'start'}  {
162    -constraints {unixOrPc}
163    -body {
164        set result [slave msg test.tcl -verbose start]
165        list $result $msg
166    }
167    -result {^0 .*a-1.0 start.*b-1.0 start}
168    -match regexp
169}
170
171test tcltest-2.7 {tcltest::verbose}  {
172    -body {
173        set oldVerbosity [verbose]
174        verbose bar
175        set currentVerbosity [verbose]
176        verbose foo
177        set newVerbosity [verbose]
178        verbose $oldVerbosity
179        list $currentVerbosity $newVerbosity
180    }
181    -result {body {}}
182}
183
184test tcltest-2.8 {tcltest -verbose 'error'} {
185    -constraints {unixOrPc}
186    -body {
187        set result [slave msg test.tcl -verbose error]
188        list $result $msg
189    }
190    -result {errorInfo: foo.*errorCode: 9}
191    -match regexp
192}
193# -match, [match]
194test tcltest-3.1 {tcltest -match 'a*'} {unixOrPc} {
195    set result [slave msg test.tcl -match a* -verbose 'ps']
196    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
197            [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
198} {0 1 0 0 1}
199test tcltest-3.2 {tcltest -match 'b*'} {unixOrPc} {
200    set result [slave msg test.tcl -match b* -verbose 'ps']
201    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
202            [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
203} {0 0 1 0 1}
204test tcltest-3.3 {tcltest -match 'c*'} {unixOrPc} {
205    set result [slave msg test.tcl -match c* -verbose 'ps']
206    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
207            [regexp "Total.+4.+Passed.+0.+Skipped.+4.+Failed.+0" $msg]
208} {0 0 0 1 1}
209test tcltest-3.4 {tcltest -match 'a* b*'} {unixOrPc} {
210    set result [slave msg test.tcl -match {a* b*} -verbose 'ps']
211    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
212            [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
213} {0 1 1 0 1}
214
215test tcltest-3.5 {tcltest::match}  {
216    -body {
217        set oldMatch [match]
218        match foo
219        set currentMatch [match]
220        match bar
221        set newMatch [match]
222        match $oldMatch
223        list $currentMatch $newMatch
224    }
225    -result {foo bar}
226}
227       
228# -skip, [skip]
229test tcltest-4.1 {tcltest -skip 'a*'} {unixOrPc} {
230    set result [slave msg test.tcl -skip a* -verbose 'ps']
231    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
232            [regexp "Total.+4.+Passed.+0.+Skipped.+2.+Failed.+1" $msg]
233} {0 0 1 1 1}
234test tcltest-4.2 {tcltest -skip 'b*'} {unixOrPc} {
235    set result [slave msg test.tcl -skip b* -verbose 'ps']
236    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
237            [regexp "Total.+4.+Passed.+1.+Skipped.+2.+Failed.+1" $msg]
238} {0 1 0 1 1}
239test tcltest-4.3 {tcltest -skip 'c*'} {unixOrPc} {
240    set result [slave msg test.tcl -skip c* -verbose 'ps']
241    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
242            [regexp "Total.+4.+Passed.+1.+Skipped.+1.+Failed.+2" $msg]
243} {0 1 1 0 1}
244test tcltest-4.4 {tcltest -skip 'a* b*'} {unixOrPc} {
245    set result [slave msg test.tcl -skip {a* b*} -verbose 'ps']
246    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
247            [regexp "Total.+4.+Passed.+0.+Skipped.+3.+Failed.+1" $msg]
248} {0 0 0 1 1}
249test tcltest-4.5 {tcltest -match 'a* b*' -skip 'b*'} {unixOrPc} {
250    set result [slave msg test.tcl -match {a* b*} -skip b* -verbose 'ps']
251    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
252            [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
253} {0 1 0 0 1}
254
255test tcltest-4.6 {tcltest::skip} {
256    -body {
257        set oldSkip [skip]
258        skip foo
259        set currentSkip [skip]
260        skip bar
261        set newSkip [skip]
262        skip $oldSkip
263        list $currentSkip $newSkip
264    }
265    -result {foo bar}
266}
267
268# -constraints, -limitconstraints, [testConstraint],
269# $constraintsSpecified, [limitConstraints]
270test tcltest-5.1 {tcltest -constraints 'knownBug'} {unixOrPc} {
271    set result [slave msg test.tcl -constraints knownBug -verbose 'ps']
272    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
273            [regexp "Total.+4.+Passed.+2.+Skipped.+0.+Failed.+2" $msg]
274} {0 1 1 1 1}
275test tcltest-5.2 {tcltest -constraints 'knownBug' -limitconstraints 1} {unixOrPc} {
276    set result [slave msg test.tcl -constraints knownBug -verbose 'p' -limitconstraints 1]
277    list $result [regexp a-1.0 $msg] [regexp b-1.0 $msg] [regexp c-1.0 $msg] \
278            [regexp "Total.+4.+Passed.+1.+Skipped.+3.+Failed.+0" $msg]
279} {0 0 0 1 1}
280
281test tcltest-5.3 {testConstraint - constraint empty (tcltest::safeFetch)}  {
282    -body {
283        set r1 [testConstraint tcltestFakeConstraint]
284        set r2 [testConstraint tcltestFakeConstraint 4]
285        set r3 [testConstraint tcltestFakeConstraint]
286        list $r1 $r2 $r3
287    }
288    -result {0 4 4}
289    -cleanup {unset ::tcltest::testConstraints(tcltestFakeConstraint)}
290}
291
292# Removed this test of internals of tcltest.  Those internals have changed.
293#test tcltest-5.4 {tcltest::constraintsSpecified} {
294#    -setup {
295#       set constraintlist $::tcltest::constraintsSpecified
296#       set ::tcltest::constraintsSpecified {}
297#    }
298#    -body {
299#       set r1 $::tcltest::constraintsSpecified
300#       testConstraint tcltestFakeConstraint1 1
301#       set r2 $::tcltest::constraintsSpecified
302#       testConstraint tcltestFakeConstraint2 1
303#       set r3 $::tcltest::constraintsSpecified
304#       list $r1 $r2 $r3
305#    }
306#    -result {{} tcltestFakeConstraint1 {tcltestFakeConstraint1 tcltestFakeConstraint2}}
307#    -cleanup {
308#       set ::tcltest::constraintsSpecified $constraintlist
309#       unset ::tcltest::testConstraints(tcltestFakeConstraint1)
310#       unset ::tcltest::testConstraints(tcltestFakeConstraint2)
311#    }
312#}
313
314test tcltest-5.5 {InitConstraints: list of built-in constraints} \
315        -constraints {!singleTestInterp} \
316        -setup {tcltest::InitConstraints} \
317        -body { lsort [array names ::tcltest::testConstraints] } \
318        -result [lsort {
319    95 98 asyncPipeClose eformat emptyTest exec hasIsoLocale interactive
320    knownBug mac macCrash macOnly macOrPc macOrUnix macOrWin nonBlockFiles
321    nonPortable notRoot nt pc pcCrash pcOnly root singleTestInterp socket
322    stdio tempNotMac tempNotPc tempNotUnix tempNotWin unix unixCrash unixExecs
323    unixOnly unixOrPc unixOrWin userInteraction win winCrash winOnly
324}]
325
326# Removed this broken test.  Its usage of [limitConstraints] was not
327# in agreement with the documentation.  [limitConstraints] is supposed
328# to take an optional boolean argument, and "knownBug" ain't no boolean!
329#test tcltest-5.6 {tcltest::limitConstraints} {
330#    -setup {
331#        set keeplc $::tcltest::limitConstraints
332#        set keepkb [testConstraint knownBug]
333#    }
334#    -body {
335#        set r1 [limitConstraints]
336#        set r2 [limitConstraints knownBug]
337#        set r3 [limitConstraints]
338#        list $r1 $r2 $r3
339#    }
340#    -cleanup {
341#        limitConstraints $keeplc
342#        testConstraint knownBug $keepkb
343#    }
344#    -result {false knownBug knownBug}
345#}
346
347# -outfile, -errfile, [outputChannel], [outputFile], [errorChannel], [errorFile]
348set printerror [makeFile {
349    package require tcltest
350    namespace import ::tcltest::*
351    puts [outputChannel] "a test"
352    ::tcltest::PrintError "a really short string"
353    ::tcltest::PrintError "a really really really really really really long \
354            string containing \"quotes\" and other bad bad stuff"
355    ::tcltest::PrintError "a really really long string containing a \
356            \"Path/that/is/really/long/and/contains/no/spaces\""
357    ::tcltest::PrintError "a really really long string containing a \
358            \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\""
359    ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\""
360    exit
361} printerror.tcl]
362
363test tcltest-6.1 {tcltest -outfile, -errfile defaults} {
364    -constraints unixOrPc
365    -body {
366        slave msg $printerror
367        return $msg
368    }
369    -result {a test.*a really}
370    -match regexp
371}
372test tcltest-6.2 {tcltest -outfile a.tmp} {unixOrPc unixExecs} {
373    slave msg $printerror -outfile a.tmp
374    set result1 [catch {exec grep "a test" a.tmp}]
375    set result2 [catch {exec grep "a really" a.tmp}]
376    list [regexp "a test" $msg] [regexp "a really" $msg] \
377            $result1 $result2 [file exists a.tmp] [file delete a.tmp]
378} {0 1 0 1 1 {}}
379test tcltest-6.3 {tcltest -errfile a.tmp} {unixOrPc unixExecs} {
380    slave msg $printerror -errfile a.tmp
381    set result1 [catch {exec grep "a test" a.tmp}]
382    set result2 [catch {exec grep "a really" a.tmp}]
383    list [regexp "a test" $msg] [regexp "a really" $msg] \
384            $result1 $result2 [file exists a.tmp] [file delete a.tmp]
385} {1 0 1 0 1 {}}
386test tcltest-6.4 {tcltest -outfile a.tmp -errfile b.tmp} {unixOrPc unixExecs} {
387    slave msg $printerror -outfile a.tmp -errfile b.tmp
388    set result1 [catch {exec grep "a test" a.tmp}]
389    set result2 [catch {exec grep "a really" b.tmp}]
390    list [regexp "a test" $msg] [regexp "a really" $msg] \
391            $result1 $result2 \
392            [file exists a.tmp] [file delete a.tmp] \
393            [file exists b.tmp] [file delete b.tmp]
394} {0 0 0 0 1 {} 1 {}}
395
396test tcltest-6.5 {tcltest::errorChannel - retrieval} {
397    -setup {
398        set of [errorChannel]
399        set ::tcltest::errorChannel stderr
400    }
401    -body {
402        errorChannel
403    }
404    -result {stderr}
405    -cleanup {
406        set ::tcltest::errorChannel $of
407    }
408}
409
410test tcltest-6.6 {tcltest::errorFile (implicit errorChannel)} {
411    -setup {
412        set ef [makeFile {} efile]
413        set of [errorFile]
414        set ::tcltest::errorChannel stderr
415        set ::tcltest::errorFile stderr
416    }
417    -body {
418        set f0 [errorChannel]
419        set f1 [errorFile]
420        set f2 [errorFile $ef]
421        set f3 [errorChannel]
422        set f4 [errorFile]
423        subst {$f0;$f1;$f2;$f3;$f4}
424    }
425    -result {stderr;stderr;.*efile;file[0-9a-f]+;.*efile}
426    -match regexp
427    -cleanup {
428        errorFile $of
429        removeFile efile
430    }
431}
432test tcltest-6.7 {tcltest::outputChannel - retrieval} {
433    -setup {
434        set of [outputChannel]
435        set ::tcltest::outputChannel stdout
436    }
437    -body {
438        outputChannel
439    }
440    -result {stdout}
441    -cleanup {
442        set ::tcltest::outputChannel $of
443    }
444}
445
446test tcltest-6.8 {tcltest::outputFile (implicit outputFile)} {
447    -setup {
448        set ef [makeFile {} efile]
449        set of [outputFile]
450        set ::tcltest::outputChannel stdout
451        set ::tcltest::outputFile stdout
452    }
453    -body {
454        set f0 [outputChannel]
455        set f1 [outputFile]
456        set f2 [outputFile $ef]
457        set f3 [outputChannel]
458        set f4 [outputFile]
459        subst {$f0;$f1;$f2;$f3;$f4}
460    }
461    -result {stdout;stdout;.*efile;file[0-9a-f]+;.*efile}
462    -match regexp
463    -cleanup {
464        outputFile $of
465        removeFile efile
466    }
467}
468
469# -debug, [debug]
470# Must use child processes to test -debug because it always writes
471# messages to stdout, and we have no way to capture stdout of a
472# slave interp
473test tcltest-7.1 {tcltest test.tcl -debug 0} {unixOrPc} {
474    catch {exec [interpreter] test.tcl -debug 0} msg
475    regexp "Flags passed into tcltest" $msg
476} {0}
477test tcltest-7.2 {tcltest test.tcl -debug 1} {unixOrPc} {
478    catch {exec [interpreter] test.tcl -debug 1 -skip b*} msg
479    list [regexp userSpecifiedSkip $msg] \
480            [regexp "Flags passed into tcltest" $msg]
481} {1 0}
482test tcltest-7.3 {tcltest test.tcl -debug 1} {unixOrPc} {
483    catch {exec [interpreter] test.tcl -debug 1 -match b*} msg
484    list [regexp userSpecifiedNonMatch $msg] \
485            [regexp "Flags passed into tcltest" $msg]
486} {1 0}
487test tcltest-7.4 {tcltest test.tcl -debug 2} {unixOrPc} {
488    catch {exec [interpreter] test.tcl -debug 2} msg
489    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
490} {1 0}
491test tcltest-7.5 {tcltest test.tcl -debug 3} {unixOrPc} {
492    catch {exec [interpreter] test.tcl -debug 3} msg
493    list [regexp "Flags passed into tcltest" $msg] [regexp "Running" $msg]
494} {1 1}
495
496test tcltest-7.6 {tcltest::debug} {
497    -setup {
498        set old $::tcltest::debug
499        set ::tcltest::debug 0
500    }
501    -body {
502        set f1 [debug]
503        set f2 [debug 1]
504        set f3 [debug]
505        set f4 [debug 2]
506        set f5 [debug]
507        list $f1 $f2 $f3 $f4 $f5
508    }
509    -result {0 1 1 2 2}
510    -cleanup {
511        set ::tcltest::debug $old
512    }
513}
514removeFile test.tcl
515
516# directory tests
517
518set a [makeFile {
519    package require tcltest
520    tcltest::makeFile {} a.tmp
521    puts [tcltest::outputChannel] "testdir: [tcltest::testsDirectory]"
522    exit
523} a.tcl]
524
525set tdiaf [makeFile {} thisdirectoryisafile]
526
527set normaldirectory [makeDirectory normaldirectory]
528normalizePath normaldirectory
529
530# -tmpdir, [temporaryDirectory]
531test tcltest-8.1 {tcltest a.tcl -tmpdir a} -constraints unixOrPc -setup {
532    file delete -force thisdirectorydoesnotexist
533} -body {
534    slave msg $a -tmpdir thisdirectorydoesnotexist
535    file exists [file join thisdirectorydoesnotexist a.tmp]
536} -cleanup {
537    file delete -force thisdirectorydoesnotexist
538} -result 1
539test tcltest-8.2 {tcltest a.tcl -tmpdir thisdirectoryisafile} {
540    -constraints unixOrPc
541    -body {
542        slave msg $a -tmpdir $tdiaf
543        return $msg
544    }
545    -result {*not a directory*}
546    -match glob
547}
548# Test non-writeable directories, non-readable directories with directory flags
549set notReadableDir [file join [temporaryDirectory] notreadable]
550set notWriteableDir [file join [temporaryDirectory] notwriteable]
551makeDirectory notreadable
552makeDirectory notwriteable
553switch -- $::tcl_platform(platform) {
554    "unix" {
555        file attributes $notReadableDir -permissions 00333
556        file attributes $notWriteableDir -permissions 00555
557    }
558    default {
559        catch {file attributes $notWriteableDir -readonly 1}
560        catch {testchmod 000 $notWriteableDir}
561    }
562}
563test tcltest-8.3 {tcltest a.tcl -tmpdir notReadableDir} {
564    -constraints {unix notRoot}
565    -body {
566        slave msg $a -tmpdir $notReadableDir
567        return $msg
568    }
569    -result {*not readable*}
570    -match glob
571}
572# This constraint doesn't go at the top of the file so that it doesn't
573# interfere with tcltest-5.5
574testConstraint notFAT [expr {
575    ![string match "FAT*" [lindex [file system $notWriteableDir] 1]]
576}]
577# FAT permissions are fairly hopeless; ignore this test if that FS is used
578test tcltest-8.4 {tcltest a.tcl -tmpdir notWriteableDir} {
579    -constraints {unixOrPc notRoot notFAT}
580    -body {
581        slave msg $a -tmpdir $notWriteableDir
582        return $msg
583    }
584    -result {*not writeable*}
585    -match glob
586}
587test tcltest-8.5 {tcltest a.tcl -tmpdir normaldirectory} {
588    -constraints unixOrPc
589    -body {
590        slave msg $a -tmpdir $normaldirectory
591        # The join is necessary because the message can be split on multiple
592        # lines
593        file exists [file join $normaldirectory a.tmp]
594    }
595    -cleanup {
596        catch {file delete [file join $normaldirectory a.tmp]}
597    }
598    -result 1
599}
600cd [workingDirectory]
601test tcltest-8.6 {temporaryDirectory}  {
602    -setup {
603        set old $::tcltest::temporaryDirectory
604        set ::tcltest::temporaryDirectory $normaldirectory
605    }
606    -body {
607        set f1 [temporaryDirectory]
608        set f2 [temporaryDirectory [workingDirectory]]
609        set f3 [temporaryDirectory]
610        list $f1 $f2 $f3
611    }
612    -result "[list $normaldirectory [workingDirectory] [workingDirectory]]"
613    -cleanup {
614        set ::tcltest::temporaryDirectory $old
615    }
616}
617test tcltest-8.6a {temporaryDirectory - test format 2} -setup {
618    set old $::tcltest::temporaryDirectory
619    set ::tcltest::temporaryDirectory $normaldirectory
620} -body {
621    set f1 [temporaryDirectory]
622    set f2 [temporaryDirectory [workingDirectory]]
623    set f3 [temporaryDirectory]
624    list $f1 $f2 $f3
625} -cleanup {
626    set ::tcltest::temporaryDirectory $old
627} -result [list $normaldirectory [workingDirectory] [workingDirectory]]
628cd [temporaryDirectory]
629# -testdir, [testsDirectory]
630test tcltest-8.10 {tcltest a.tcl -testdir thisdirectorydoesnotexist} {
631    -constraints unixOrPc
632    -setup {
633        file delete -force thisdirectorydoesnotexist
634    }
635    -body {
636        slave msg $a -testdir thisdirectorydoesnotexist
637        return $msg
638    }
639    -match glob
640    -result {*does not exist*}
641}
642test tcltest-8.11 {tcltest a.tcl -testdir thisdirectoryisafile} {
643    -constraints unixOrPc
644    -body {
645        slave msg $a -testdir $tdiaf
646        return $msg
647    }
648    -match glob
649    -result {*not a directory*}
650}
651test tcltest-8.12 {tcltest a.tcl -testdir notReadableDir} {
652    -constraints {unix notRoot}
653    -body {
654        slave msg $a -testdir $notReadableDir
655        return $msg
656    }
657    -match glob
658    -result {*not readable*}
659}
660test tcltest-8.13 {tcltest a.tcl -testdir normaldirectory} {
661    -constraints unixOrPc
662    -body {
663        slave msg $a -testdir $normaldirectory
664        # The join is necessary because the message can be split on multiple
665        # lines
666        list [string first "testdir: $normaldirectory" [join $msg]] \
667            [file exists [file join [temporaryDirectory] a.tmp]]
668    }
669    -cleanup {
670        file delete [file join [temporaryDirectory] a.tmp]
671    }
672    -result {0 1}
673}
674cd [workingDirectory]
675set current [pwd]
676test tcltest-8.14 {testsDirectory} {
677    -setup {
678        set old $::tcltest::testsDirectory
679        set ::tcltest::testsDirectory $normaldirectory
680    }
681    -body {
682        set f1 [testsDirectory]
683        set f2 [testsDirectory $current]
684        set f3 [testsDirectory]
685        list $f1 $f2 $f3
686    }
687    -result "[list $normaldirectory $current $current]"
688    -cleanup {
689        set ::tcltest::testsDirectory $old
690    }
691}
692# [workingDirectory]
693test tcltest-8.60 {::workingDirectory}  {
694    -setup {
695        set old $::tcltest::workingDirectory
696        set current [pwd]
697        set ::tcltest::workingDirectory $normaldirectory
698        cd $normaldirectory
699    }
700    -body {
701        set f1 [workingDirectory]
702        set f2 [pwd]
703        set f3 [workingDirectory $current]
704        set f4 [pwd]
705        set f5 [workingDirectory]
706        list $f1 $f2 $f3 $f4 $f5
707    }
708    -result "[list $normaldirectory \
709                   $normaldirectory \
710                   $current \
711                   $current \
712                   $current]"
713    -cleanup {
714        set ::tcltest::workingDirectory $old
715        cd $current
716    }
717}
718
719# clean up from directory testing
720
721switch $::tcl_platform(platform) {
722    "unix" {
723        file attributes $notReadableDir -permissions 777
724        file attributes $notWriteableDir -permissions 777
725    }
726    default {
727        catch {file attributes $notWriteableDir -readonly 0}
728    }
729}
730
731file delete -force $notReadableDir $notWriteableDir
732removeFile a.tcl
733removeFile thisdirectoryisafile
734removeDirectory normaldirectory
735
736# -file, -notfile, [matchFiles], [skipFiles]
737test tcltest-9.1 {-file d*.tcl} -constraints {unixOrPc} -setup {
738    set old [testsDirectory]
739    testsDirectory [file dirname [info script]]
740} -body {
741    slave msg [file join [testsDirectory] all.tcl] -file d*.test
742    return $msg
743} -cleanup {
744    testsDirectory $old
745} -match regexp -result {dstring\.test}
746
747test tcltest-9.2 {-file d*.tcl} -constraints {unixOrPc} -setup {
748    set old [testsDirectory]
749    testsDirectory [file dirname [info script]]
750} -body {
751    slave msg [file join [testsDirectory] all.tcl] \
752            -file d*.test -notfile dstring*
753    regexp {dstring\.test} $msg
754} -cleanup {
755    testsDirectory $old
756} -result 0
757
758test tcltest-9.3 {matchFiles}  {
759    -body {
760        set old [matchFiles]
761        matchFiles foo
762        set current [matchFiles]
763        matchFiles bar
764        set new [matchFiles]
765        matchFiles $old
766        list $current $new
767    }
768    -result {foo bar}
769}
770
771test tcltest-9.4 {skipFiles} {
772    -body {
773        set old [skipFiles]
774        skipFiles foo
775        set current [skipFiles]
776        skipFiles bar
777        set new [skipFiles]
778        skipFiles $old
779        list $current $new
780    }
781    -result {foo bar}
782}
783
784test tcltest-9.5 {GetMatchingFiles: Bug 1119798} -setup {
785    set d [makeDirectory tmp]
786    makeDirectory foo $d
787    makeFile {} fee $d
788    file copy [file join [file dirname [info script]] all.tcl] $d
789} -body {
790    slave msg [file join [temporaryDirectory] all.tcl] -file f*
791    regexp {exiting with errors:} $msg
792} -cleanup {
793    file delete [file join $d all.tcl]
794    removeFile fee $d
795    removeDirectory foo $d
796    removeDirectory tmp
797} -result 0
798
799# -preservecore, [preserveCore]
800set mc [makeFile {
801    package require tcltest
802    namespace import ::tcltest::test
803    test makecore {make a core file} {
804        set f [open core w]
805        close $f
806    } {}
807    ::tcltest::cleanupTests
808    return
809} makecore.tcl]
810
811cd [temporaryDirectory]
812test tcltest-10.1 {-preservecore 0} {unixOrPc} {
813    slave msg $mc -preservecore 0
814    file delete core
815    regexp "Core file produced" $msg
816} {0}
817test tcltest-10.2 {-preservecore 1} {unixOrPc} {
818    slave msg $mc -preservecore 1
819    file delete core
820    regexp "Core file produced" $msg
821} {1}
822test tcltest-10.3 {-preservecore 2} {unixOrPc} {
823    slave msg $mc -preservecore 2
824    file delete core
825    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
826            [regexp "core-" $msg] [file delete core-makecore]
827} {1 1 1 {}}
828test tcltest-10.4 {-preservecore 3} {unixOrPc} {
829    slave msg $mc -preservecore 3
830    file delete core
831    list [regexp "Core file produced" $msg] [regexp "Moving file to" $msg] \
832            [regexp "core-" $msg] [file delete core-makecore]
833} {1 1 1 {}}
834
835# Removing this test.  It makes no sense to test the ability of
836# [preserveCore] to accept an invalid value that will cause errors
837# in other parts of tcltest's operation.
838#test tcltest-10.5 {preserveCore} {
839#    -body {
840#       set old [preserveCore]
841#       set result [preserveCore foo]
842#       set result2 [preserveCore]
843#       preserveCore $old
844#       list $result $result2
845#    }
846#    -result {foo foo}
847#}
848removeFile makecore.tcl
849
850# -load, -loadfile, [loadScript], [loadFile]
851set contents {
852    package require tcltest
853    namespace import tcltest::*
854    puts [outputChannel] $::tcltest::loadScript
855    exit
856}
857set loadfile [makeFile $contents load.tcl]
858
859test tcltest-12.1 {-load xxx} {unixOrPc} {
860    slave msg $loadfile -load xxx
861    return $msg
862} {xxx}
863
864# Using child process because of -debug usage.
865test tcltest-12.2 {-loadfile load.tcl} {unixOrPc} {
866    catch {exec [interpreter] $loadfile -debug 2 -loadfile $loadfile} msg
867    list \
868            [regexp {tcltest} [join [list $msg] [split $msg \n]]] \
869            [regexp {loadScript} [join [list $msg] [split $msg \n]]]
870} {1 1}
871
872test tcltest-12.3 {loadScript} {
873    -setup {
874        set old $::tcltest::loadScript
875        set ::tcltest::loadScript {}
876    }
877    -body {
878        set f1 [loadScript]
879        set f2 [loadScript xxx]
880        set f3 [loadScript]
881        list $f1 $f2 $f3
882    }
883    -result {{} xxx xxx}
884    -cleanup {
885        set ::tcltest::loadScript $old
886    }
887}
888
889test tcltest-12.4 {loadFile} {
890    -setup {
891        set olds $::tcltest::loadScript
892        set ::tcltest::loadScript {}
893        set oldf $::tcltest::loadFile
894        set ::tcltest::loadFile {}
895    }
896    -body {
897        set f1 [loadScript]
898        set f2 [loadFile]
899        set f3 [loadFile $loadfile]
900        set f4 [loadScript]
901        set f5 [loadFile]
902        list $f1 $f2 $f3 $f4 $f5
903    }
904    -result "[list {} {} $loadfile $contents $loadfile]\n"
905    -cleanup {
906        set ::tcltest::loadScript $olds
907        set ::tcltest::loadFile $oldf
908    }
909}
910removeFile load.tcl
911
912# [interpreter]
913test tcltest-13.1 {interpreter} {
914    -setup {
915        set old $::tcltest::tcltest
916        set ::tcltest::tcltest tcltest
917    }
918    -body {
919        set f1 [interpreter]
920        set f2 [interpreter tclsh]
921        set f3 [interpreter]
922        list $f1 $f2 $f3
923    }
924    -result {tcltest tclsh tclsh}
925    -cleanup {
926        set ::tcltest::tcltest $old
927    }
928}
929
930# -singleproc, [singleProcess]
931set spd [makeDirectory singleprocdir]
932makeFile {
933    set foo 1
934} single1.test $spd
935
936makeFile {
937    unset foo
938} single2.test $spd
939
940set allfile [makeFile {
941    package require tcltest
942    namespace import tcltest::*
943    testsDirectory [file join [temporaryDirectory] singleprocdir]
944    runAllTests
945} all-single.tcl $spd]
946cd [workingDirectory]
947
948test tcltest-14.1 {-singleproc - single process} {
949    -constraints {unixOrPc}
950    -body {
951        slave msg $allfile -singleproc 0 -tmpdir [temporaryDirectory]
952        return $msg
953    }
954    -result {Test file error: can't unset .foo.: no such variable}
955    -match regexp
956}
957
958test tcltest-14.2 {-singleproc - multiple process} {
959    -constraints {unixOrPc}
960    -body {
961        slave msg $allfile -singleproc 1 -tmpdir [temporaryDirectory]
962        return $msg
963    }
964    -result {single1.test.*single2.test.*all\-single.tcl:.*Total.*0.*Passed.*0.*Skipped.*0.*Failed.*0}
965    -match regexp
966}
967
968test tcltest-14.3 {singleProcess} {
969    -setup {
970        set old $::tcltest::singleProcess
971        set ::tcltest::singleProcess 0
972    }
973    -body {
974        set f1 [singleProcess]
975        set f2 [singleProcess 1]
976        set f3 [singleProcess]
977        list $f1 $f2 $f3
978    }
979    -result {0 1 1}
980    -cleanup {
981        set ::tcltest::singleProcess $old
982    }
983}
984removeFile single1.test $spd
985removeFile single2.test $spd
986removeDirectory singleprocdir
987
988# -asidefromdir, -relateddir, [matchDirectories], [skipDirectories]
989
990# Before running these tests, need to set up test subdirectories with their own
991# all.tcl files.
992
993set dtd [makeDirectory dirtestdir]
994set dtd1 [makeDirectory dirtestdir2.1 $dtd]
995set dtd2 [makeDirectory dirtestdir2.2 $dtd]
996set dtd3 [makeDirectory dirtestdir2.3 $dtd]
997makeFile {
998    package require tcltest
999    namespace import -force tcltest::*
1000    testsDirectory [file join [temporaryDirectory] dirtestdir]
1001    runAllTests
1002} all.tcl $dtd
1003makeFile {
1004    package require tcltest
1005    namespace import -force tcltest::*
1006    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.1]
1007    runAllTests
1008} all.tcl $dtd1
1009makeFile {
1010    package require tcltest
1011    namespace import -force tcltest::*
1012    testsDirectory [file join [temporaryDirectory]  dirtestdir dirtestdir2.2]
1013    runAllTests
1014} all.tcl $dtd2
1015makeFile {
1016    package require tcltest
1017    namespace import -force tcltest::*
1018    testsDirectory [file join [temporaryDirectory] dirtestdir dirtestdir2.3]
1019    runAllTests
1020} all.tcl $dtd3
1021
1022test tcltest-15.1 {basic directory walking} {
1023    -constraints {unixOrPc}
1024    -body {
1025        if {[slave msg \
1026                [file join $dtd all.tcl] \
1027                -tmpdir [temporaryDirectory]] == 1} {
1028            error $msg
1029        }
1030    }
1031    -match regexp
1032    -returnCodes 1
1033    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123].*Tests located in:.*dirtestdir2.[123]}
1034}
1035
1036test tcltest-15.2 {-asidefromdir} {
1037    -constraints {unixOrPc}
1038    -body {
1039        if {[slave msg \
1040                [file join $dtd all.tcl] \
1041                -asidefromdir dirtestdir2.3 \
1042                -tmpdir [temporaryDirectory]] == 1} {
1043            error $msg
1044        }
1045    }
1046    -match regexp
1047    -returnCodes 1
1048    -result {Tests located in:.*dirtestdir.*Tests located in:.*dirtestdir2.[12].*Tests located in:.*dirtestdir2.[12].*dirtestdir2.[12] test ended at .*~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1049Error:  No test files remain after applying your match and skip patterns!
1050Error:  No test files remain after applying your match and skip patterns!
1051Error:  No test files remain after applying your match and skip patterns!$}
1052}
1053
1054test tcltest-15.3 {-relateddir, non-existent dir} {
1055    -constraints {unixOrPc}
1056    -body {
1057        if {[slave msg \
1058                [file join $dtd all.tcl] \
1059                -relateddir [file join [temporaryDirectory] dirtestdir0] \
1060                -tmpdir [temporaryDirectory]] == 1} {
1061            error $msg
1062        }
1063    }
1064    -returnCodes 1
1065    -match regexp
1066    -result {[^~]|dirtestdir[^2]}
1067}
1068
1069test tcltest-15.4 {-relateddir, subdir} {
1070    -constraints {unixOrPc}
1071    -body {
1072        if {[slave msg \
1073                [file join $dtd all.tcl] \
1074                -relateddir dirtestdir2.1 -tmpdir [temporaryDirectory]] == 1} {
1075            error $msg
1076        }
1077    }
1078    -returnCodes 1
1079    -match regexp
1080    -result {Tests located in:.*dirtestdir2.[^23]}
1081}
1082test tcltest-15.5 {-relateddir, -asidefromdir} {
1083    -constraints {unixOrPc}
1084    -body {
1085        if {[slave msg \
1086                [file join $dtd all.tcl] \
1087                -relateddir "dirtestdir2.1 dirtestdir2.2" \
1088                -asidefromdir dirtestdir2.2 \
1089                -tmpdir [temporaryDirectory]] == 1} {
1090            error $msg
1091        }
1092    }
1093    -match regexp
1094    -returnCodes 1
1095    -result {Tests located in:.*dirtestdir2.[^23]}
1096}
1097
1098test tcltest-15.6 {matchDirectories} {
1099    -setup {
1100        set old [matchDirectories]
1101        set ::tcltest::matchDirectories {}
1102    }
1103    -body {
1104        set r1 [matchDirectories]
1105        set r2 [matchDirectories foo]
1106        set r3 [matchDirectories]
1107        list $r1 $r2 $r3
1108    }
1109    -cleanup {
1110        set ::tcltest::matchDirectories $old
1111    }
1112    -result {{} foo foo}
1113}
1114
1115test tcltest-15.7 {skipDirectories} {
1116    -setup {
1117        set old [skipDirectories]
1118        set ::tcltest::skipDirectories {}
1119    }
1120    -body {
1121        set r1 [skipDirectories]
1122        set r2 [skipDirectories foo]
1123        set r3 [skipDirectories]
1124        list $r1 $r2 $r3
1125    }
1126    -cleanup {
1127        set ::tcltest::skipDirectories $old
1128    }
1129    -result {{} foo foo}
1130}
1131removeDirectory dirtestdir2.3 $dtd
1132removeDirectory dirtestdir2.2 $dtd
1133removeDirectory dirtestdir2.1 $dtd
1134removeDirectory dirtestdir
1135
1136# TCLTEST_OPTIONS
1137test tcltest-19.1 {TCLTEST_OPTIONS default} -setup {
1138        if {[info exists ::env(TCLTEST_OPTIONS)]} {
1139            set oldoptions $::env(TCLTEST_OPTIONS)
1140        } else {
1141            set oldoptions none
1142        }
1143        # set this to { } instead of just {} to get around quirk in
1144        # Windows env handling that removes empty elements from env array.
1145        set ::env(TCLTEST_OPTIONS) { }
1146        interp create slave1
1147        slave1 eval [list set argv {-debug 2}]
1148        slave1 alias puts puts
1149        interp create slave2
1150        slave2 alias puts puts
1151    } -cleanup {
1152        interp delete slave2
1153        interp delete slave1
1154        if {$oldoptions == "none"} {
1155            unset ::env(TCLTEST_OPTIONS)
1156        } else {
1157            set ::env(TCLTEST_OPTIONS) $oldoptions
1158        }
1159    } -body {
1160        slave1 eval [package ifneeded tcltest [package provide tcltest]]
1161        slave1 eval tcltest::debug
1162        set ::env(TCLTEST_OPTIONS) "-debug 3"
1163        slave2 eval [package ifneeded tcltest [package provide tcltest]]
1164        slave2 eval tcltest::debug
1165    } -result {^3$} -match regexp -output\
1166{tcltest::debug\s+= 2.*tcltest::debug\s+= 3}
1167
1168# Begin testing of tcltest procs ...
1169
1170cd [temporaryDirectory]
1171# PrintError
1172test tcltest-20.1 {PrintError} {unixOrPc} {
1173    set result [slave msg $printerror]
1174    list $result [regexp "Error:  a really short string" $msg] \
1175            [regexp "     \"quotes\"" $msg] [regexp "    \"Path" $msg] \
1176            [regexp "    \"Really" $msg] [regexp Problem $msg]
1177} {1 1 1 1 1 1}
1178cd [workingDirectory]
1179removeFile printerror.tcl
1180
1181# test::test
1182test tcltest-21.0 {name and desc but no args specified} -setup {
1183    set v [verbose]
1184} -cleanup {
1185    verbose $v
1186} -body {
1187   verbose {}
1188   test tcltest-21.0.0 bar
1189} -result {}
1190
1191test tcltest-21.1 {expect with glob} {
1192    -body {
1193        list a b c d e
1194    }
1195    -match glob
1196    -result {[ab] b c d e}
1197}
1198
1199test tcltest-21.2 {force a test command failure} {
1200    -body {
1201        test tcltest-21.2.0 {
1202            return 2
1203        } {1}
1204    }
1205    -returnCodes 1
1206    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1207}
1208
1209test tcltest-21.3 {test command with setup} {
1210    -setup {
1211        set foo 1
1212    }
1213    -body {
1214        set foo
1215    }
1216    -cleanup {unset foo}
1217    -result {1}
1218}
1219
1220test tcltest-21.4 {test command with cleanup failure} {
1221    -setup {
1222        if {[info exists foo]} {
1223            unset foo
1224        }
1225        set fail $::tcltest::currentFailure
1226        set v [verbose]
1227    }
1228    -body {
1229        verbose {}
1230        test tcltest-21.4.0 {foo-1} {
1231            -cleanup {unset foo}
1232        }
1233    }
1234    -result {^$}
1235    -match regexp
1236    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
1237    -output "Test cleanup failed:.*can't unset \"foo\": no such variable"
1238}
1239
1240test tcltest-21.5 {test command with setup failure} {
1241    -setup {
1242        if {[info exists foo]} {
1243            unset foo
1244        }
1245        set fail $::tcltest::currentFailure
1246    }
1247    -body {
1248        test tcltest-21.5.0 {foo-2} {
1249            -setup {unset foo}
1250        }
1251    }
1252    -result {^$}
1253    -match regexp
1254    -cleanup {set ::tcltest::currentFailure $fail}
1255    -output "Test setup failed:.*can't unset \"foo\": no such variable"
1256}
1257
1258test tcltest-21.6 {test command - setup occurs before cleanup & before script} {
1259    -setup {set v [verbose]; set fail $::tcltest::currentFailure}
1260    -body {
1261        verbose {}
1262        test tcltest-21.6.0 {foo-3} {
1263            -setup {
1264                if {[info exists foo]} {
1265                    unset foo
1266                }
1267                set foo 1
1268                set expected 2
1269            }
1270            -body {
1271                incr foo
1272                set foo
1273            }
1274            -cleanup {
1275                if {$foo != 2} {
1276                    puts [outputChannel] "foo is wrong"
1277                } else {
1278                    puts [outputChannel] "foo is 2"
1279                }
1280            }
1281            -result {$expected}
1282        }
1283    }
1284    -cleanup {verbose $v; set ::tcltest::currentFailure $fail}
1285    -result {^$}
1286    -match regexp
1287    -output "foo is 2"
1288}
1289
1290test tcltest-21.7 {test command - bad flag} {
1291    -setup {set fail $::tcltest::currentFailure}
1292    -cleanup {set ::tcltest::currentFailure $fail}
1293    -body {
1294        test tcltest-21.7.0 {foo-4} {
1295            -foobar {}
1296        }
1297    }
1298    -returnCodes 1
1299    -result {bad option "-foobar": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1300}
1301
1302# alternate test command format (these are the same as 21.1-21.6, with the
1303# exception of being in the all-inline format)
1304
1305test tcltest-21.7a {expect with glob} \
1306        -body {list a b c d e} \
1307        -result {[ab] b c d e} \
1308        -match glob
1309
1310test tcltest-21.8 {force a test command failure} \
1311    -setup {set fail $::tcltest::currentFailure} \
1312    -body {
1313        test tcltest-21.8.0 {
1314            return 2
1315        } {1}
1316    } \
1317    -returnCodes 1 \
1318    -cleanup {set ::tcltest::currentFailure $fail} \
1319    -result {bad option "1": must be -body, -cleanup, -constraints, -errorOutput, -match, -output, -result, -returnCodes, or -setup}
1320
1321test tcltest-21.9 {test command with setup} \
1322        -setup {set foo 1} \
1323        -body {set foo} \
1324        -cleanup {unset foo} \
1325        -result {1}
1326
1327test tcltest-21.10 {test command with cleanup failure} -setup {
1328    if {[info exists foo]} {
1329        unset foo
1330    }
1331    set fail $::tcltest::currentFailure
1332    set v [verbose]
1333} -cleanup {
1334    verbose $v
1335    set ::tcltest::currentFailure $fail
1336} -body {
1337    verbose {}
1338    test tcltest-21.10.0 {foo-1} -cleanup {unset foo}
1339} -result {^$} -match regexp \
1340        -output {Test cleanup failed:.*can't unset \"foo\": no such variable}
1341
1342test tcltest-21.11 {test command with setup failure} -setup {
1343    if {[info exists foo]} {
1344        unset foo
1345    }
1346    set fail $::tcltest::currentFailure
1347} -cleanup {set ::tcltest::currentFailure $fail} -body {
1348    test tcltest-21.11.0 {foo-2} -setup {unset foo}
1349} -result {^$} -output {Test setup failed:.*can't unset \"foo\": no such variable} -match regexp
1350
1351test tcltest-21.12 {
1352        test command - setup occurs before cleanup & before script
1353} -setup {
1354        set fail $::tcltest::currentFailure
1355        set v [verbose]
1356} -cleanup {
1357        verbose $v
1358        set ::tcltest::currentFailure $fail
1359} -body {
1360    verbose {}
1361    test tcltest-21.12.0 {foo-3} -setup {
1362        if {[info exists foo]} {
1363            unset foo
1364        }
1365        set foo 1
1366        set expected 2
1367    }  -body {
1368        incr foo
1369        set foo
1370    }  -cleanup {
1371        if {$foo != 2} {
1372            puts [outputChannel] "foo is wrong"
1373        } else {
1374            puts [outputChannel] "foo is 2"
1375        }
1376    }  -result {$expected}
1377} -result {^$} -output {foo is 2} -match regexp
1378
1379# test all.tcl usage (runAllTests); simulate .test file failure, as well as
1380# crashes to determine whether or not these errors are logged.
1381
1382set atd [makeDirectory alltestdir]
1383makeFile {
1384    package require tcltest
1385    namespace import -force tcltest::*
1386    testsDirectory [file join [temporaryDirectory] alltestdir]
1387    runAllTests
1388} all.tcl $atd
1389makeFile {
1390    exit 1
1391} exit.test $atd
1392makeFile {
1393    error "throw an error"
1394} error.test $atd
1395makeFile {
1396    package require tcltest
1397    namespace import -force tcltest::*
1398    test foo-1.1 {foo} {
1399        -body { return 1 }
1400        -result {1}
1401    }
1402    cleanupTests
1403} test.test $atd
1404
1405# Must use a child process because stdout/stderr parsing can't be
1406# duplicated in slave interp.
1407test tcltest-22.1 {runAllTests} {
1408    -constraints {unixOrPc}
1409    -body {
1410        exec [interpreter] \
1411                [file join $atd all.tcl] \
1412                -verbose t -tmpdir [temporaryDirectory]
1413    }
1414    -match regexp
1415    -result "Test files exiting with errors:.*error.test.*exit.test"
1416}
1417removeDirectory alltestdir
1418
1419# makeFile, removeFile, makeDirectory, removeDirectory, viewFile
1420test tcltest-23.1 {makeFile} {
1421    -setup {
1422        set mfdir [file join [temporaryDirectory] mfdir]
1423        file mkdir $mfdir
1424    }
1425    -body {
1426        makeFile {} t1.tmp
1427        makeFile {} et1.tmp $mfdir
1428        list [file exists [file join [temporaryDirectory] t1.tmp]] \
1429                [file exists [file join $mfdir et1.tmp]]
1430    }
1431    -cleanup {
1432        file delete -force $mfdir \
1433                [file join [temporaryDirectory] t1.tmp]
1434    }
1435    -result {1 1}
1436}
1437test tcltest-23.2 {removeFile} {
1438    -setup {
1439        set mfdir [file join [temporaryDirectory] mfdir]
1440        file mkdir $mfdir
1441        makeFile {} t1.tmp
1442        makeFile {} et1.tmp $mfdir
1443        if  {![file exists [file join [temporaryDirectory] t1.tmp]] || \
1444                ![file exists [file join $mfdir et1.tmp]]} {
1445            error "file creation didn't work"
1446        }
1447    }
1448    -body {
1449        removeFile t1.tmp
1450        removeFile et1.tmp $mfdir
1451        list [file exists [file join [temporaryDirectory] t1.tmp]] \
1452                [file exists [file join $mfdir et1.tmp]]
1453    }
1454    -cleanup {
1455        file delete -force $mfdir \
1456                [file join [temporaryDirectory] t1.tmp]
1457    }
1458    -result {0 0}
1459}
1460test tcltest-23.3 {makeDirectory} {
1461    -body {
1462        set mfdir [file join [temporaryDirectory] mfdir]
1463        file mkdir $mfdir
1464        makeDirectory d1
1465        makeDirectory d2 $mfdir
1466        list [file exists [file join [temporaryDirectory] d1]] \
1467                [file exists [file join $mfdir d2]]
1468    }
1469    -cleanup {
1470        file delete -force [file join [temporaryDirectory] d1] $mfdir
1471    }
1472    -result {1 1}
1473}
1474test tcltest-23.4 {removeDirectory} {
1475    -setup {
1476        set mfdir [makeDirectory mfdir]
1477        makeDirectory t1
1478        makeDirectory t2 $mfdir
1479        if {![file exists $mfdir] || \
1480                ![file exists [file join [temporaryDirectory] $mfdir t2]]} {
1481            error "setup failed - directory not created"
1482        }
1483    }
1484    -body {
1485        removeDirectory t1
1486        removeDirectory t2 $mfdir
1487        list [file exists [file join [temporaryDirectory] t1]] \
1488                [file exists [file join $mfdir t2]]
1489    }
1490    -result {0 0}
1491}
1492test tcltest-23.5 {viewFile} {
1493    -body {
1494        set mfdir [file join [temporaryDirectory] mfdir]
1495        file mkdir $mfdir
1496        makeFile {foobar} t1.tmp
1497        makeFile {foobarbaz} t2.tmp $mfdir
1498        list [viewFile t1.tmp] [viewFile t2.tmp $mfdir]
1499    }
1500    -result {foobar foobarbaz}
1501    -cleanup {
1502        file delete -force $mfdir
1503        removeFile t1.tmp
1504    }
1505}
1506
1507# customMatch
1508proc matchNegative { expected actual } {
1509   set match 0
1510   foreach a $actual e $expected {
1511      if { $a != $e } {
1512         set match 1
1513        break
1514      }
1515   }
1516   return $match
1517}
1518
1519test tcltest-24.0 {
1520        customMatch: syntax
1521} -body {
1522        list [catch {customMatch} result] $result
1523} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1524
1525test tcltest-24.1 {
1526        customMatch: syntax
1527} -body {
1528        list [catch {customMatch foo} result] $result
1529} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1530
1531test tcltest-24.2 {
1532        customMatch: syntax
1533} -body {
1534        list [catch {customMatch foo bar baz} result] $result
1535} -result [list 1 "wrong # args: should be \"customMatch mode script\""]
1536
1537test tcltest-24.3 {
1538        customMatch: argument checking
1539} -body {
1540        list [catch {customMatch bad "a \{ b"} result] $result
1541} -result [list 1 "invalid customMatch script; can't evaluate after completion"]
1542
1543test tcltest-24.4 {
1544        test: valid -match values
1545} -body {
1546        list [catch {
1547                test tcltest-24.4.0 {} \
1548                        -match [namespace current]::noSuchMode
1549        } result] $result
1550} -match glob -result {1 *bad -match value*}
1551
1552test tcltest-24.5 {
1553        test: valid -match values
1554} -setup {
1555        customMatch [namespace current]::alwaysMatch "format 1 ;#"
1556} -body {
1557        list [catch {
1558                test tcltest-24.5.0 {} \
1559                        -match [namespace current]::noSuchMode
1560        } result] $result
1561} -match glob -result {1 *bad -match value*: must be *alwaysMatch,*}
1562
1563test tcltest-24.6 {
1564        customMatch: -match script that always matches
1565} -setup {
1566        customMatch [namespace current]::alwaysMatch "format 1 ;#"
1567        set v [verbose]
1568} -body {
1569        verbose {}
1570        test tcltest-24.6.0 {} -match [namespace current]::alwaysMatch \
1571                -body {format 1} -result 0
1572} -cleanup {
1573        verbose $v
1574} -result {} -output {} -errorOutput {}
1575
1576test tcltest-24.7 {
1577        customMatch: replace default -exact matching
1578} -setup {
1579        set saveExactMatchScript $::tcltest::CustomMatch(exact)
1580        customMatch exact "format 1 ;#"
1581        set v [verbose]
1582} -body {
1583        verbose {}
1584        test tcltest-24.7.0 {} -body {format 1} -result 0
1585} -cleanup {
1586        verbose $v
1587        customMatch exact $saveExactMatchScript
1588        unset saveExactMatchScript
1589} -result {} -output {}
1590
1591test tcltest-24.9 {
1592        customMatch: error during match
1593} -setup {
1594        proc errorDuringMatch args {return -code error "match returned error"}
1595        customMatch [namespace current]::errorDuringMatch \
1596                [namespace code errorDuringMatch]
1597        set v [verbose]
1598        set fail $::tcltest::currentFailure
1599} -body {
1600        verbose {}
1601        test tcltest-24.9.0 {} -match [namespace current]::errorDuringMatch
1602} -cleanup {
1603        verbose $v
1604        set ::tcltest::currentFailure $fail
1605} -match glob -result {} -output {*FAILED*match returned error*}
1606
1607test tcltest-24.10 {
1608        customMatch: bad return from match command
1609} -setup {
1610        proc nonBooleanReturn args {return foo}
1611        customMatch nonBooleanReturn [namespace code nonBooleanReturn]
1612        set v [verbose]
1613        set fail $::tcltest::currentFailure
1614} -body {
1615        verbose {}
1616        test tcltest-24.10.0 {} -match nonBooleanReturn
1617} -cleanup {
1618        verbose $v
1619        set ::tcltest::currentFailure $fail
1620} -match glob -result {} -output {*FAILED*expected boolean value*}
1621
1622test tcltest-24.11 {
1623        test: -match exact
1624} -body {
1625        set result {A B C}
1626} -match exact -result {A B C}
1627
1628test tcltest-24.12 {
1629        test: -match exact      match command eval in ::, not caller namespace
1630} -setup {
1631        set saveExactMatchScript $::tcltest::CustomMatch(exact)
1632        customMatch exact [list string equal]
1633        set v [verbose]
1634        proc string args {error {called [string] in caller namespace}}
1635} -body {
1636        verbose {}
1637        test tcltest-24.12.0 {} -body {format 1} -result 1
1638} -cleanup {
1639        rename string {}
1640        verbose $v
1641        customMatch exact $saveExactMatchScript
1642        unset saveExactMatchScript
1643} -match exact -result {} -output {}
1644
1645test tcltest-24.13 {
1646        test: -match exact      failure
1647} -setup {
1648        set saveExactMatchScript $::tcltest::CustomMatch(exact)
1649        customMatch exact [list string equal]
1650        set v [verbose]
1651        set fail $::tcltest::currentFailure
1652} -body {
1653        verbose {}
1654        test tcltest-24.13.0 {} -body {format 1} -result 0
1655} -cleanup {
1656        set ::tcltest::currentFailure $fail
1657        verbose $v
1658        customMatch exact $saveExactMatchScript
1659        unset saveExactMatchScript
1660} -match glob -result {} -output {*FAILED*Result was:
16611*(exact matching):
16620*}
1663
1664test tcltest-24.14 {
1665        test: -match glob
1666} -body {
1667        set result {A B C}
1668} -match glob -result {A B*}
1669
1670test tcltest-24.15 {
1671        test: -match glob       failure
1672} -setup {
1673        set v [verbose]
1674        set fail $::tcltest::currentFailure
1675} -body {
1676        verbose {}
1677        test tcltest-24.15.0 {} -match glob -body {format {A B C}} \
1678                -result {A B* }
1679} -cleanup {
1680        set ::tcltest::currentFailure $fail
1681        verbose $v
1682} -match glob -result {} -output {*FAILED*Result was:
1683*(glob matching):
1684*}
1685
1686test tcltest-24.16 {
1687        test: -match regexp
1688} -body {
1689        set result {A B C}
1690} -match regexp -result {A B.*}
1691
1692test tcltest-24.17 {
1693        test: -match regexp     failure
1694} -setup {
1695        set fail $::tcltest::currentFailure
1696        set v [verbose]
1697} -body {
1698        verbose {}
1699        test tcltest-24.17.0 {} -match regexp -body {format {A B C}} \
1700                -result {A B.* X}
1701} -cleanup {
1702        set ::tcltest::currentFailure $fail
1703        verbose $v
1704} -match glob -result {} -output {*FAILED*Result was:
1705*(regexp matching):
1706*}
1707
1708test tcltest-24.18 {
1709        test: -match custom     forget namespace qualification
1710} -setup {
1711        set fail $::tcltest::currentFailure
1712        set v [verbose]
1713        customMatch negative matchNegative
1714} -body {
1715        verbose {}
1716        test tcltest-24.18.0 {} -match negative -body {format {A B C}} \
1717                -result {A B X}
1718} -cleanup {
1719        set ::tcltest::currentFailure $fail
1720        verbose $v
1721} -match glob -result {} -output {*FAILED*Error testing result:*}
1722
1723test tcltest-24.19 {
1724        test: -match custom
1725} -setup {
1726        set v [verbose]
1727        customMatch negative [namespace code matchNegative]
1728} -body {
1729        verbose {}
1730        test tcltest-24.19.0 {} -match negative -body {format {A B C}} \
1731                -result {A B X}
1732} -cleanup {
1733        verbose $v
1734} -match exact -result {} -output {}
1735
1736test tcltest-24.20 {
1737        test: -match custom     failure
1738} -setup {
1739        set fail $::tcltest::currentFailure
1740        set v [verbose]
1741        customMatch negative [namespace code matchNegative]
1742} -body {
1743        verbose {}
1744        test tcltest-24.20.0 {} -match negative -body {format {A B C}} \
1745                -result {A B C}
1746} -cleanup {
1747        set ::tcltest::currentFailure $fail
1748        verbose $v
1749} -match glob -result {} -output {*FAILED*Result was:
1750*(negative matching):
1751*}
1752
1753test tcltest-25.1 {
1754        constraint of setup/cleanup (Bug 589859)
1755} -setup {
1756        set foo 0
1757} -body {
1758        # Buggy tcltest will generate result of 2
1759        test tcltest-25.1.0 {} -constraints knownBug -setup {
1760            incr foo
1761        } -body {
1762            incr foo
1763        } -cleanup {
1764            incr foo
1765        } -match glob -result *
1766        set foo
1767} -cleanup {
1768        unset foo
1769} -result 0
1770
1771test tcltest-25.2 {
1772        puts -nonewline (Bug 612786)
1773} -body {
1774        puts -nonewline stdout bla
1775        puts -nonewline stdout bla
1776} -output {blabla}
1777
1778test tcltest-25.3 {
1779        reported return code (Bug 611922)
1780} -setup {
1781        set fail $::tcltest::currentFailure
1782        set v [verbose]
1783} -body {
1784        verbose {}
1785        test tcltest-25.3.0 {} -body {
1786            error foo
1787        }
1788} -cleanup {
1789        set ::tcltest::currentFailure $fail
1790        verbose $v
1791} -match glob -output {*generated error; Return code was: 1*}
1792
1793test tcltest-26.1 {Bug/RFE 1017151} -setup {
1794    makeFile {
1795        package require tcltest
1796        set ::errorInfo "Should never see this"
1797        tcltest::test tcltest-26.1.0 {
1798            no errorInfo when only return code mismatch
1799        } -body {
1800            set x 1
1801        } -returnCodes error -result 1
1802        tcltest::cleanupTests
1803    } test.tcl
1804} -body {
1805    slave msg [file join [temporaryDirectory] test.tcl]
1806    return $msg
1807} -cleanup {
1808    removeFile test.tcl
1809} -match glob -result {*
1810---- Return code should have been one of: 1
1811==== tcltest-26.1.0 FAILED*}
1812
1813test tcltest-26.2 {Bug/RFE 1017151} -setup {
1814    makeFile {
1815        package require tcltest
1816        set ::errorInfo "Should never see this"
1817        tcltest::test tcltest-26.2.0 {do not mask body errorInfo} -body {
1818            error "body error"
1819        } -cleanup {
1820            error "cleanup error"
1821        } -result 1
1822        tcltest::cleanupTests
1823    } test.tcl
1824} -body {
1825    slave msg [file join [temporaryDirectory] test.tcl]
1826    return $msg
1827} -cleanup {
1828    removeFile test.tcl
1829} -match glob -result {*
1830---- errorInfo: body error
1831*
1832---- errorInfo(cleanup): cleanup error*}
1833
1834cleanupTests
1835}
1836
1837namespace delete ::tcltest::test
1838return
Note: See TracBrowser for help on using the repository browser.