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
} {
79 stdout
puts "About to 'puts $f $contents'"
85 proc removeFile
{name
} {
89 # In case tclcompat is not selected
90 if {![exists
-proc puts]} {
91 proc puts {{-nonewline {}} {chan stdout
} msg
} {
92 if {${-nonewline} ni
{-nonewline {}}} {
93 ${-nonewline} puts $msg
95 $chan puts {*}${-nonewline} $msg
98 proc close {chan args
} {
101 proc fileevent {args
} {
106 proc script_source
{script
} {
107 lassign
[info source $script] f l
114 proc error_source
{} {
115 lassign
[info stacktrace
] p f l
122 proc package-or-skip
{name
} {
124 package require
$name
126 puts [format "%16s: --- skipped" $::argv0]
131 proc testConstraint
{constraint bool
} {
132 set ::tcltest::testConstraints($constraint) $bool
135 testConstraint
{utf8
} [expr {[string length
"\xc2\xb5"] == 1}]
136 testConstraint
{references
} [expr {[info commands ref
] ne
""}]
137 testConstraint
{jim
} 1
138 testConstraint
{tcl
} 0
140 proc bytestring
{x
} {
144 # Note: We don't support -output or -errorOutput yet
145 proc test
{id descr args
} {
146 set a
[dict create
-returnCodes {ok
return} -match exact
-result {} -constraints {} -body {} -setup {} -cleanup {}]
147 if {[lindex $args 0] ni
[dict keys
$a]} {
148 if {[llength $args] == 2} {
149 lassign
$args body result constraints
150 } elseif
{[llength $args] == 3} {
151 lassign
$args constraints body result
153 return -code error "$id: Wrong syntax for tcltest::test v1"
155 tailcall test
$id $descr -body $body -result $result -constraints $constraints
157 # tcltest::test v2 syntax
160 incr ::testinfo(numtests
)
161 if {$::testinfo(verbose
)} {
162 puts -nonewline "$id "
165 foreach c
$a(-constraints) {
166 if {[info exists
::tcltest::testConstraints($c)]} {
167 if {$::tcltest::testConstraints($c)} {
170 incr ::testinfo(numskip
)
171 if {$::testinfo(verbose
)} {
178 catch {uplevel 1 $a(-setup)}
179 set rc
[catch {uplevel 1 $a(-body)} result opts
]
180 catch {uplevel 1 $a(-cleanup)}
182 if {[info return $rc] ni
$a(-returnCodes) && $rc ni
$a(-returnCodes)} {
184 set expected
"rc=$a(-returnCodes) result=$a(-result)"
185 set result
"rc=[info return $rc] result=$result"
187 if {$a(-match) eq
"exact"} {
188 set ok
[string equal
$a(-result) $result]
189 } elseif
{$a(-match) eq
"glob"} {
190 set ok
[string match
$a(-result) $result]
191 } elseif
{$a(-match) eq
"regexp"} {
192 set ok
[regexp $a(-result) $result]
194 return -code error "$id: unknown match type: $a(-match)"
196 set expected
$a(-result)
200 if {$::testinfo(verbose
)} {
203 incr ::testinfo(numpass
)
207 if {!$::testinfo(verbose
)} {
208 puts -nonewline "$id "
212 set source [script_source
$a(-body)]
214 set source [error_source
]
216 puts "Expected: '$expected'"
217 puts "Got : '$result'"
219 incr ::testinfo(numfail
)
220 lappend ::testinfo(failed
) [list $id $descr $source $expected $result]
221 if {$::testinfo(stoponerror
)} {
226 proc ::tcltest::cleanupTests {} {
231 if {$::testinfo(verbose
)} {
232 puts -nonewline "\n$::argv0"
234 puts -nonewline [format "%16s" $::argv0]
236 puts [format ": Total %5d Passed %5d Skipped %5d Failed %5d" \
237 $::testinfo(numtests
) $::testinfo(numpass
) $::testinfo(numskip
) $::testinfo(numfail
)]
238 if {$::testinfo(numfail
)} {
239 puts [string repeat
- 60]
240 puts "FAILED: $::testinfo(numfail)"
241 foreach failed
$::testinfo(failed
) {
242 foreach {id descr
source expected result
} $failed {}
245 puts [string repeat
- 60]
247 if {$::testinfo(numfail
)} {
253 error "deliberate error"
256 if {$testinfo(verbose
)} {
257 puts "==== $argv0 ===="