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
{} {
99 set name
[format "%s/tcltmp-%04x" [env TMPDIR
/tmp
] [rand
65536]]
104 proc removeFile
{name
} {
108 # In case tclcompat is not selected
109 if {![exists
-proc puts]} {
110 proc puts {{-nonewline {}} {chan stdout
} msg
} {
111 if {${-nonewline} ni
{-nonewline {}}} {
112 ${-nonewline} puts $msg
114 $chan puts {*}${-nonewline} $msg
117 proc close {chan args
} {
120 proc fileevent {args
} {
125 proc script_source
{script
} {
126 lassign
[info source $script] f l
133 proc error_source
{} {
134 lassign
[info stacktrace
] p f l
141 proc package-or-skip
{name
} {
143 package require
$name
145 puts [format "%16s: --- skipped" $::argv0]
150 proc testConstraint
{constraint
{bool
{}}} {
152 if {[info exists
::tcltest::testConstraints($constraint)]} {
153 return $::tcltest::testConstraints($constraint)
155 return -code error "unknown constraint: $constraint"
158 set ::tcltest::testConstraints($constraint) $bool
162 testConstraint
{utf8
} [expr {[string length
"\xc2\xb5"] == 1}]
163 testConstraint
{references
} [expr {[info commands ref
] ne
""}]
164 testConstraint
{jim
} 1
165 testConstraint
{tcl
} 0
167 proc bytestring
{x
} {
171 # Note: We don't support -output or -errorOutput yet
172 proc test
{id descr args
} {
173 set a
[dict create
-returnCodes {ok
return} -match exact
-result {} -constraints {} -body {} -setup {} -cleanup {}]
174 if {[lindex $args 0] ni
[dict keys
$a]} {
175 if {[llength $args] == 2} {
176 lassign
$args body result constraints
177 } elseif
{[llength $args] == 3} {
178 lassign
$args constraints body result
180 return -code error "$id: Wrong syntax for tcltest::test v1"
182 tailcall test
$id $descr -body $body -result $result -constraints $constraints
184 # tcltest::test v2 syntax
187 incr ::testinfo(numtests
)
188 if {$::testinfo(verbose
)} {
189 puts -nonewline "$id "
192 foreach c
$a(-constraints) {
193 if {![testConstraint
$c]} {
194 incr ::testinfo(numskip
)
195 if {$::testinfo(verbose
)} {
202 catch {uplevel 1 $a(-setup)}
203 set rc
[catch {uplevel 1 $a(-body)} result opts
]
204 catch {uplevel 1 $a(-cleanup)}
206 if {[info return $rc] ni
$a(-returnCodes) && $rc ni
$a(-returnCodes)} {
208 set expected
"rc=$a(-returnCodes) result=$a(-result)"
209 set result
"rc=[info return $rc] result=$result"
211 if {$a(-match) eq
"exact"} {
212 set ok
[string equal
$a(-result) $result]
213 } elseif
{$a(-match) eq
"glob"} {
214 set ok
[string match
$a(-result) $result]
215 } elseif
{$a(-match) eq
"regexp"} {
216 set ok
[regexp $a(-result) $result]
218 return -code error "$id: unknown match type: $a(-match)"
220 set expected
$a(-result)
224 if {$::testinfo(verbose
)} {
227 incr ::testinfo(numpass
)
231 if {!$::testinfo(verbose
)} {
232 puts -nonewline "$id "
236 set source [script_source
$a(-body)]
238 set source [error_source
]
240 puts "Expected: '$expected'"
241 puts "Got : '$result'"
243 incr ::testinfo(numfail
)
244 lappend ::testinfo(failed
) [list $id $descr $source $expected $result]
245 if {$::testinfo(stoponerror
)} {
250 proc ::tcltest::cleanupTests {} {
255 if {$::testinfo(reported
)} {
258 incr ::testinfo(reported
)
260 if {$::testinfo(verbose
)} {
261 puts -nonewline "\n$::argv0"
263 puts -nonewline [format "%16s" $::argv0]
265 puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
266 $::testinfo(numtests
) $::testinfo(numpass
) $::testinfo(numskip
) $::testinfo(numfail
)]
267 if {$::testinfo(numfail
)} {
268 puts [string repeat
- 60]
269 puts "FAILED: $::testinfo(numfail)"
270 foreach failed
$::testinfo(failed
) {
271 foreach {id descr
source expected result
} $failed {}
274 puts [string repeat
- 60]
276 if {$::testinfo(numfail
)} {
282 error "deliberate error"
285 if {$testinfo(verbose
)} {
286 puts "==== $argv0 ===="