1 # tcltest compatibilty/wrapper/extension
4 set testinfo
(verbose
) 0
5 set testinfo
(numpass
) 0
6 set testinfo
(stoponerror
) 0
7 set testinfo
(numfail
) 0
8 set testinfo
(numskip
) 0
9 set testinfo
(numtests
) 0
10 set testinfo
(reported
) 0
11 set testinfo
(failed
) {}
13 if {[lsearch $argv "-verbose"] >= 0 ||
[info exists env
(testverbose
)]} {
14 incr testinfo
(verbose
)
16 if {[lsearch $argv "-stoponerror"] >= 0 ||
[info exists env
(stoponerror
)]} {
17 incr testinfo
(stoponerror
)
20 proc needs
{type what
{packages
{}}} {
21 if {$type eq
"constraint"} {
22 if {![info exists
::tcltest::testConstraints($what)]} {
23 set ::tcltest::testConstraints($what) 0
25 if {![set ::tcltest::testConstraints($what)]} {
26 skiptest
" (constraint $what)"
31 # Does it exist already?
32 if {[info commands
$what] ne
""} {
35 if {$packages eq
""} {
36 # e.g. exec command is in exec package
40 catch {package require
$p}
42 if {[info commands
$what] ne
""} {
45 skiptest
" (command $what)"
47 error "Unknown needs type: $type"
50 proc skiptest
{{msg
{}}} {
51 puts [format "%16s: --- skipped$msg" $::argv0]
55 # If tcl, just use tcltest
56 if {[catch {info version
}]} {
57 package require
Tcl 8.5
58 package require
tcltest 2.1
59 namespace import
tcltest::*
61 if {$testinfo(verbose
)} {
62 configure
-verbose bps
67 ::tcltest::cleanupTests
72 # Add some search paths for packages
74 # The directory containing the original script
75 lappend auto_path
[file dirname
$argv0]
77 # The directory containing the jimsh executable
78 lappend auto_path
[file dirname
[info nameofexecutable
]]
80 # For Jim, this is reasonable compatible tcltest
81 proc makeFile
{contents name
{dir
{}}} {
85 set filename $dir/$name
87 set f
[open $filename w
]
93 proc makeDirectory
{name
} {
98 proc temporaryDirectory
{} {{dir
{}}} {
100 set dir
[file join [env TMPDIR
/tmp
] [format "tcltmp-%04x" [rand
65536]]]
106 proc removeFile
{args
} {
107 file delete
-force {*}$args
110 proc removeDirectory
{name
} {
111 file delete
-force $name
114 # In case tclcompat is not selected
115 if {![exists
-proc puts]} {
116 proc puts {{-nonewline {}} {chan stdout
} msg
} {
117 if {${-nonewline} ni
{-nonewline {}}} {
118 ${-nonewline} puts $msg
120 $chan puts {*}${-nonewline} $msg
123 proc close {chan args
} {
126 proc fileevent {args
} {
131 proc script_source
{script
} {
132 lassign
[info source $script] f l
139 proc error_source
{} {
140 lassign
[info stacktrace
] p f l
147 proc package-or-skip
{name
} {
149 package require
$name
151 puts [format "%16s: --- skipped" $::argv0]
156 proc testConstraint
{constraint
{bool
{}}} {
158 if {[info exists
::tcltest::testConstraints($constraint)]} {
159 return $::tcltest::testConstraints($constraint)
161 return -code error "unknown constraint: $constraint"
164 set ::tcltest::testConstraints($constraint) $bool
168 testConstraint
{utf8
} [expr {[string length
"\xc2\xb5"] == 1}]
169 testConstraint
{references
} [expr {[info commands ref
] ne
""}]
170 testConstraint
{jim
} 1
171 testConstraint
{tcl
} 0
173 proc bytestring
{x
} {
177 # Note: We don't support -output or -errorOutput yet
178 proc test
{id descr args
} {
179 set a
[dict create
-returnCodes {ok
return} -match exact
-result {} -constraints {} -body {} -setup {} -cleanup {}]
180 if {[lindex $args 0] ni
[dict keys
$a]} {
181 if {[llength $args] == 2} {
182 lassign
$args body result constraints
183 } elseif
{[llength $args] == 3} {
184 lassign
$args constraints body result
186 return -code error "$id: Wrong syntax for tcltest::test v1"
188 tailcall test
$id $descr -body $body -result $result -constraints $constraints
190 # tcltest::test v2 syntax
193 incr ::testinfo(numtests
)
194 if {$::testinfo(verbose
)} {
195 puts -nonewline "$id "
198 foreach c
$a(-constraints) {
199 if {![testConstraint
$c]} {
200 incr ::testinfo(numskip
)
201 if {$::testinfo(verbose
)} {
208 if {[catch {uplevel 1 $a(-setup)} msg
]} {
209 if {$::testinfo(verbose
)} {
210 puts "-setup failed: $msg"
213 set rc
[catch {uplevel 1 $a(-body)} result opts
]
214 if {[catch {uplevel 1 $a(-cleanup)} msg
]} {
215 if {$::testinfo(verbose
)} {
216 puts "-cleanup failed: $msg"
220 if {[info return $rc] ni
$a(-returnCodes) && $rc ni
$a(-returnCodes)} {
222 set expected
"rc=$a(-returnCodes) result=$a(-result)"
223 set result
"rc=[info return $rc] result=$result"
225 if {$a(-match) eq
"exact"} {
226 set ok
[string equal
$a(-result) $result]
227 } elseif
{$a(-match) eq
"glob"} {
228 set ok
[string match
$a(-result) $result]
229 } elseif
{$a(-match) eq
"regexp"} {
230 set ok
[regexp $a(-result) $result]
232 return -code error "$id: unknown match type: $a(-match)"
234 set expected
$a(-result)
238 if {$::testinfo(verbose
)} {
241 incr ::testinfo(numpass
)
245 if {!$::testinfo(verbose
)} {
246 puts -nonewline "$id "
250 set source [script_source
$a(-body)]
252 set source [error_source
]
254 puts "Expected: '$expected'"
255 puts "Got : '$result'"
257 incr ::testinfo(numfail
)
258 lappend ::testinfo(failed
) [list $id $descr $source $expected $result]
259 if {$::testinfo(stoponerror
)} {
264 proc ::tcltest::cleanupTests {} {
265 file delete
[temporaryDirectory
]
270 if {$::testinfo(reported
)} {
273 incr ::testinfo(reported
)
275 if {$::testinfo(verbose
)} {
276 puts -nonewline "\n$::argv0"
278 puts -nonewline [format "%16s" $::argv0]
280 puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
281 $::testinfo(numtests
) $::testinfo(numpass
) $::testinfo(numskip
) $::testinfo(numfail
)]
282 if {$::testinfo(numfail
)} {
283 puts [string repeat
- 60]
284 puts "FAILED: $::testinfo(numfail)"
285 foreach failed
$::testinfo(failed
) {
286 foreach {id descr
source expected result
} $failed {}
289 puts [string repeat
- 60]
291 if {$::testinfo(numfail
)} {
297 error "deliberate error"
300 if {$testinfo(verbose
)} {
301 puts "==== $argv0 ===="