tests/testing.tcl

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