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
(failed
) {}
12 if {[lsearch $argv "-verbose"] >= 0 ||
[info exists env
(testverbose
)]} {
13 incr testinfo
(verbose
)
15 if {[lsearch $argv "-stoponerror"] >= 0 ||
[info exists env
(stoponerror
)]} {
16 incr testinfo
(stoponerror
)
19 proc needs
{type what
{packages
{}}} {
20 if {$type eq
"constraint"} {
21 if {![info exists
::tcltest::testConstraints($what)]} {
22 set ::tcltest::testConstraints($what) 0
24 if {![set ::tcltest::testConstraints($what)]} {
25 skiptest
" (constraint $what)"
30 # Does it exist already?
31 if {[info commands
$what] ne
""} {
34 if {$packages eq
""} {
35 # e.g. exec command is in exec package
39 catch {package require
$p}
41 if {[info commands
$what] ne
""} {
44 skiptest
" (command $what)"
46 error "Unknown needs type: $type"
49 proc skiptest
{{msg
{}}} {
50 puts [format "%16s: --- skipped$msg" $::argv0]
54 # If tcl, just use tcltest
55 if {[catch {info version
}]} {
56 package require
Tcl 8.5
57 package require
tcltest 2.1
58 namespace import
tcltest::*
60 if {$testinfo(verbose
)} {
61 configure
-verbose bps
66 ::tcltest::cleanupTests
71 # Add some search paths for packages
73 # The directory containing the original script
74 lappend auto_path
[file dirname
$argv0]
76 # The directory containing the jimsh executable
77 lappend auto_path
[file dirname
[info nameofexecutable
]]
79 # For Jim, this is reasonable compatible tcltest
80 proc makeFile
{contents name
{dir
{}}} {
84 set filename $dir/$name
86 set f
[open $filename w
]
92 proc makeDirectory
{name
} {
97 proc temporaryDirectory
{} {
98 set name
[format "%s/tcltmp-%04x" [env TMPDIR
/tmp
] [rand
65536]]
103 proc removeFile
{name
} {
107 # In case tclcompat is not selected
108 if {![exists
-proc puts]} {
109 proc puts {{-nonewline {}} {chan stdout
} msg
} {
110 if {${-nonewline} ni
{-nonewline {}}} {
111 ${-nonewline} puts $msg
113 $chan puts {*}${-nonewline} $msg
116 proc close {chan args
} {
119 proc fileevent {args
} {
124 proc script_source
{script
} {
125 lassign
[info source $script] f l
132 proc error_source
{} {
133 lassign
[info stacktrace
] p f l
140 proc package-or-skip
{name
} {
142 package require
$name
144 puts [format "%16s: --- skipped" $::argv0]
149 proc testConstraint
{constraint
{bool
{}}} {
151 if {[info exists
::tcltest::testConstraints($constraint)]} {
152 return $::tcltest::testConstraints($constraint)
154 return -code error "unknown constraint: $c"
157 set ::tcltest::testConstraints($constraint) $bool
161 testConstraint
{utf8
} [expr {[string length
"\xc2\xb5"] == 1}]
162 testConstraint
{references
} [expr {[info commands ref
] ne
""}]
163 testConstraint
{jim
} 1
164 testConstraint
{tcl
} 0
166 proc bytestring
{x
} {
170 # Note: We don't support -output or -errorOutput yet
171 proc test
{id descr args
} {
172 set a
[dict create
-returnCodes {ok
return} -match exact
-result {} -constraints {} -body {} -setup {} -cleanup {}]
173 if {[lindex $args 0] ni
[dict keys
$a]} {
174 if {[llength $args] == 2} {
175 lassign
$args body result constraints
176 } elseif
{[llength $args] == 3} {
177 lassign
$args constraints body result
179 return -code error "$id: Wrong syntax for tcltest::test v1"
181 tailcall test
$id $descr -body $body -result $result -constraints $constraints
183 # tcltest::test v2 syntax
186 incr ::testinfo(numtests
)
187 if {$::testinfo(verbose
)} {
188 puts -nonewline "$id "
191 foreach c
$a(-constraints) {
192 if {![testConstraint
$c]} {
193 incr ::testinfo(numskip
)
194 if {$::testinfo(verbose
)} {
201 catch {uplevel 1 $a(-setup)}
202 set rc
[catch {uplevel 1 $a(-body)} result opts
]
203 catch {uplevel 1 $a(-cleanup)}
205 if {[info return $rc] ni
$a(-returnCodes) && $rc ni
$a(-returnCodes)} {
207 set expected
"rc=$a(-returnCodes) result=$a(-result)"
208 set result
"rc=[info return $rc] result=$result"
210 if {$a(-match) eq
"exact"} {
211 set ok
[string equal
$a(-result) $result]
212 } elseif
{$a(-match) eq
"glob"} {
213 set ok
[string match
$a(-result) $result]
214 } elseif
{$a(-match) eq
"regexp"} {
215 set ok
[regexp $a(-result) $result]
217 return -code error "$id: unknown match type: $a(-match)"
219 set expected
$a(-result)
223 if {$::testinfo(verbose
)} {
226 incr ::testinfo(numpass
)
230 if {!$::testinfo(verbose
)} {
231 puts -nonewline "$id "
235 set source [script_source
$a(-body)]
237 set source [error_source
]
239 puts "Expected: '$expected'"
240 puts "Got : '$result'"
242 incr ::testinfo(numfail
)
243 lappend ::testinfo(failed
) [list $id $descr $source $expected $result]
244 if {$::testinfo(stoponerror
)} {
249 proc ::tcltest::cleanupTests {} {
254 if {$::testinfo(verbose
)} {
255 puts -nonewline "\n$::argv0"
257 puts -nonewline [format "%16s" $::argv0]
259 puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
260 $::testinfo(numtests
) $::testinfo(numpass
) $::testinfo(numskip
) $::testinfo(numfail
)]
261 if {$::testinfo(numfail
)} {
262 puts [string repeat
- 60]
263 puts "FAILED: $::testinfo(numfail)"
264 foreach failed
$::testinfo(failed
) {
265 foreach {id descr
source expected result
} $failed {}
268 puts [string repeat
- 60]
270 if {$::testinfo(numfail
)} {
276 error "deliberate error"
279 if {$testinfo(verbose
)} {
280 puts "==== $argv0 ===="