tcltest.tcl

   1 # tcltest compatibilty/wrapper/extension
   2
   3 # Common code
   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) {}
  11
  12 set testdir [file dirname $::argv0]
  13 set bindir [file dirname [info nameofexecutable]]
  14
  15 if {[lsearch $argv "-verbose"] >= 0 || [info exists env(testverbose)]} {
  16         incr testinfo(verbose)
  17 }
  18 if {[lsearch $argv "-stoponerror"] >= 0 || [info exists env(stoponerror)]} {
  19         incr testinfo(stoponerror)
  20 }
  21
  22 proc needs {type what {packages {}}} {
  23         if {$type eq "constraint"} {
  24                 if {![info exists ::tcltest::testConstraints($what)]} {
  25                         set ::tcltest::testConstraints($what) 0
  26                 }
  27                 if {![set ::tcltest::testConstraints($what)]} {
  28                         skiptest " (constraint $what)"
  29                 }
  30                 return
  31         }
  32         if {$type eq "cmd"} {
  33                 # Does it exist already?
  34                 if {[info commands $what] ne ""} {
  35                         return
  36                 }
  37                 if {$packages eq ""} {
  38                         # e.g. exec command is in exec package
  39                         set packages $what
  40                 }
  41                 foreach p $packages {
  42                         catch {package require $p}
  43                 }
  44                 if {[info commands $what] ne ""} {
  45                         return
  46                 }
  47                 skiptest " (command $what)"
  48         }
  49         error "Unknown needs type: $type"
  50 }
  51
  52 proc skiptest {{msg {}}} {
  53         puts [format "%16s:   --- skipped$msg" $::argv0]
  54         exit 0
  55 }
  56
  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::*
  62
  63         if {$testinfo(verbose)} {
  64                 configure -verbose bps
  65         }
  66         testConstraint utf8 1
  67         testConstraint tcl 1
  68         proc testreport {} {
  69                 ::tcltest::cleanupTests
  70         }
  71         return
  72 }
  73
  74 lappend auto_path $testdir $bindir [file dirname [pwd]]
  75
  76 # For Jim, this is reasonable compatible tcltest
  77 proc makeFile {contents name} {
  78         set f [open $name w]
  79         stdout puts "About to 'puts $f $contents'"
  80         puts $f $contents
  81         close $f
  82         return $name
  83 }
  84
  85 proc removeFile {name} {
  86         file delete $name
  87 }
  88
  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
  94                 } else {
  95                         $chan puts {*}${-nonewline} $msg
  96                 }
  97         }
  98         proc close {chan args} {
  99                 $chan close {*}$args
 100         }
 101         proc fileevent {args} {
 102                 {*}$args
 103         }
 104 }
 105
 106 proc script_source {script} {
 107         lassign [info source $script] f l
 108         if {$f ne ""} {
 109                 puts "At      : $f:$l"
 110                 return \t$f:$l
 111         }
 112 }
 113
 114 proc error_source {} {
 115         lassign [info stacktrace] p f l
 116         if {$f ne ""} {
 117                 puts "At      : $f:$l"
 118                 return \t$f:$l
 119         }
 120 }
 121
 122 proc package-or-skip {name} {
 123         if {[catch {
 124                 package require $name
 125         }]} {
 126                 puts [format "%16s:   --- skipped" $::argv0]
 127                 exit 0
 128         }
 129 }
 130
 131 proc testConstraint {constraint bool} {
 132         set ::tcltest::testConstraints($constraint) $bool
 133 }
 134
 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
 139
 140 proc bytestring {x} {
 141         return $x
 142 }
 143
 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
 152                 } else {
 153                         return -code error "$id: Wrong syntax for tcltest::test v1"
 154                 }
 155                 tailcall test $id $descr -body $body -result $result -constraints $constraints
 156         }
 157         # tcltest::test v2 syntax
 158         array set a $args
 159
 160         incr ::testinfo(numtests)
 161         if {$::testinfo(verbose)} {
 162                 puts -nonewline "$id "
 163         }
 164
 165         foreach c $a(-constraints) {
 166                 if {[info exists ::tcltest::testConstraints($c)]} {
 167                         if {$::tcltest::testConstraints($c)} {
 168                                 continue
 169                         }
 170                         incr ::testinfo(numskip)
 171                         if {$::testinfo(verbose)} {
 172                                 puts "SKIP"
 173                         }
 174                         return
 175                 }
 176         }
 177
 178         catch {uplevel 1 $a(-setup)}
 179         set rc [catch {uplevel 1 $a(-body)} result opts]
 180         catch {uplevel 1 $a(-cleanup)}
 181
 182         if {[info return $rc] ni $a(-returnCodes) && $rc ni $a(-returnCodes)} {
 183                 set ok 0
 184                 set expected "rc=$a(-returnCodes) result=$a(-result)"
 185                 set result "rc=[info return $rc] result=$result"
 186         } else {
 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]
 193                 } else {
 194                         return -code error "$id: unknown match type: $a(-match)"
 195                 }
 196                 set expected $a(-result)
 197         }
 198
 199         if {$ok} {
 200                 if {$::testinfo(verbose)} {
 201                         puts "OK  $descr"
 202                 }
 203                 incr ::testinfo(numpass)
 204                 return
 205         }
 206
 207         if {!$::testinfo(verbose)} {
 208                 puts -nonewline "$id "
 209         }
 210         puts "ERR $descr"
 211         if {$rc in {0 2}} {
 212                 set source [script_source $a(-body)]
 213         } else {
 214                 set source [error_source]
 215         }
 216         puts "Expected: '$expected'"
 217         puts "Got     : '$result'"
 218         puts ""
 219         incr ::testinfo(numfail)
 220         lappend ::testinfo(failed) [list $id $descr $source $expected $result]
 221         if {$::testinfo(stoponerror)} {
 222                 exit 1
 223         }
 224 }
 225
 226 proc ::tcltest::cleanupTests {} {
 227         tailcall testreport
 228 }
 229
 230 proc testreport {} {
 231         if {$::testinfo(verbose)} {
 232                 puts -nonewline "\n$::argv0"
 233         } else {
 234                 puts -nonewline [format "%16s" $::argv0]
 235         }
 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 {}
 243                         puts "$source\t$id"
 244                 }
 245                 puts [string repeat - 60]
 246         }
 247         if {$::testinfo(numfail)} {
 248                 exit 1
 249         }
 250 }
 251
 252 proc testerror {} {
 253         error "deliberate error"
 254 }
 255
 256 if {$testinfo(verbose)} {
 257         puts "==== $argv0 ===="
 258 }