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 set testdir
[file dirname
$::argv0]
13 set bindir
[file dirname
[info nameofexecutable
]]
15 if {[lsearch $argv "-verbose"] >= 0 ||
[info exists env
(testverbose
)]} {
16 incr testinfo
(verbose
)
18 if {[lsearch $argv "-stoponerror"] >= 0 ||
[info exists env
(stoponerror
)]} {
19 incr testinfo
(stoponerror
)
22 proc needs
{type what
{packages
{}}} {
23 if {$type eq
"constraint"} {
24 if {![info exists
::tcltest::testConstraints($what)]} {
25 set ::tcltest::testConstraints($what) 0
27 if {![set ::tcltest::testConstraints($what)]} {
28 skiptest
" (constraint $what)"
33 # Does it exist already?
34 if {[info commands
$what] ne
""} {
37 if {$packages eq
""} {
38 # e.g. exec command is in exec package
42 catch {package require
$p}
44 if {[info commands
$what] ne
""} {
47 skiptest
" (command $what)"
49 error "Unknown needs type: $type"
52 proc skiptest
{{msg
{}}} {
53 puts [format "%16s: --- skipped$msg" $::argv0]
57 # If tcl, just use tcltest
58 if {[catch {info version
}]} {
59 package require
Tcl 8.5
60 package require
tcltest 2.1
61 namespace import
tcltest::*
63 if {$testinfo(verbose
)} {
64 configure
-verbose bps
69 ::tcltest::cleanupTests
74 lappend auto_path
$testdir $bindir [file dirname
[pwd]]
76 # For Jim, this is reasonable compatible tcltest
77 proc makeFile
{contents name
{dir
{}}} {
81 set filename $dir/$name
83 set f
[open $filename w
]
89 proc makeDirectory
{name
} {
94 proc temporaryDirectory
{} {
95 set name
[format "%s/tcltmp-%04x" [env TMPDIR
/tmp
] [rand
65536]]
100 proc removeFile
{name
} {
104 # In case tclcompat is not selected
105 if {![exists
-proc puts]} {
106 proc puts {{-nonewline {}} {chan stdout
} msg
} {
107 if {${-nonewline} ni
{-nonewline {}}} {
108 ${-nonewline} puts $msg
110 $chan puts {*}${-nonewline} $msg
113 proc close {chan args
} {
116 proc fileevent {args
} {
121 proc script_source
{script
} {
122 lassign
[info source $script] f l
129 proc error_source
{} {
130 lassign
[info stacktrace
] p f l
137 proc package-or-skip
{name
} {
139 package require
$name
141 puts [format "%16s: --- skipped" $::argv0]
146 proc testConstraint
{constraint
{bool
{}}} {
148 if {[info exists
::tcltest::testConstraints($constraint)]} {
149 return $::tcltest::testConstraints($constraint)
151 return -code error "unknown constraint: $c"
154 set ::tcltest::testConstraints($constraint) $bool
158 testConstraint
{utf8
} [expr {[string length
"\xc2\xb5"] == 1}]
159 testConstraint
{references
} [expr {[info commands ref
] ne
""}]
160 testConstraint
{jim
} 1
161 testConstraint
{tcl
} 0
163 proc bytestring
{x
} {
167 # Note: We don't support -output or -errorOutput yet
168 proc test
{id descr args
} {
169 set a
[dict create
-returnCodes {ok
return} -match exact
-result {} -constraints {} -body {} -setup {} -cleanup {}]
170 if {[lindex $args 0] ni
[dict keys
$a]} {
171 if {[llength $args] == 2} {
172 lassign
$args body result constraints
173 } elseif
{[llength $args] == 3} {
174 lassign
$args constraints body result
176 return -code error "$id: Wrong syntax for tcltest::test v1"
178 tailcall test
$id $descr -body $body -result $result -constraints $constraints
180 # tcltest::test v2 syntax
183 incr ::testinfo(numtests
)
184 if {$::testinfo(verbose
)} {
185 puts -nonewline "$id "
188 foreach c
$a(-constraints) {
189 if {![testConstraint
$c]} {
190 incr ::testinfo(numskip
)
191 if {$::testinfo(verbose
)} {
198 catch {uplevel 1 $a(-setup)}
199 set rc
[catch {uplevel 1 $a(-body)} result opts
]
200 catch {uplevel 1 $a(-cleanup)}
202 if {[info return $rc] ni
$a(-returnCodes) && $rc ni
$a(-returnCodes)} {
204 set expected
"rc=$a(-returnCodes) result=$a(-result)"
205 set result
"rc=[info return $rc] result=$result"
207 if {$a(-match) eq
"exact"} {
208 set ok
[string equal
$a(-result) $result]
209 } elseif
{$a(-match) eq
"glob"} {
210 set ok
[string match
$a(-result) $result]
211 } elseif
{$a(-match) eq
"regexp"} {
212 set ok
[regexp $a(-result) $result]
214 return -code error "$id: unknown match type: $a(-match)"
216 set expected
$a(-result)
220 if {$::testinfo(verbose
)} {
223 incr ::testinfo(numpass
)
227 if {!$::testinfo(verbose
)} {
228 puts -nonewline "$id "
232 set source [script_source
$a(-body)]
234 set source [error_source
]
236 puts "Expected: '$expected'"
237 puts "Got : '$result'"
239 incr ::testinfo(numfail
)
240 lappend ::testinfo(failed
) [list $id $descr $source $expected $result]
241 if {$::testinfo(stoponerror
)} {
246 proc ::tcltest::cleanupTests {} {
251 if {$::testinfo(verbose
)} {
252 puts -nonewline "\n$::argv0"
254 puts -nonewline [format "%16s" $::argv0]
256 puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
257 $::testinfo(numtests
) $::testinfo(numpass
) $::testinfo(numskip
) $::testinfo(numfail
)]
258 if {$::testinfo(numfail
)} {
259 puts [string repeat
- 60]
260 puts "FAILED: $::testinfo(numfail)"
261 foreach failed
$::testinfo(failed
) {
262 foreach {id descr
source expected result
} $failed {}
265 puts [string repeat
- 60]
267 if {$::testinfo(numfail
)} {
273 error "deliberate error"
276 if {$testinfo(verbose
)} {
277 puts "==== $argv0 ===="