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(reported) 0
  11 set testinfo(failed) {}
  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         if {$type eq "package"} {
  48                 if {[catch {package require $what}]} {
  49                         skiptest " (package $what)"
  50                 }
  51                 return
  52         }
  53         error "Unknown needs type: $type"
  54 }
  55
  56 proc skiptest {{msg {}}} {
  57         puts [format "%16s:   --- skipped$msg" $::argv0]
  58         exit 0
  59 }
  60
  61 # If tcl, just use tcltest
  62 if {[catch {info version}]} {
  63         package require Tcl 8.5
  64         package require tcltest 2.1
  65         namespace import tcltest::*
  66
  67         if {$testinfo(verbose)} {
  68                 configure -verbose bps
  69         }
  70         testConstraint utf8 1
  71         testConstraint tcl 1
  72         proc testreport {} {
  73                 ::tcltest::cleanupTests
  74         }
  75         return
  76 }
  77
  78 # Add some search paths for packages
  79 if {[exists argv0]} {
  80         # The directory containing the original script
  81         lappend auto_path [file dirname $argv0]
  82 }
  83 # The directory containing the jimsh executable
  84 lappend auto_path [file dirname [info nameofexecutable]]
  85
  86 # For Jim, this is reasonable compatible tcltest
  87 proc makeFile {contents name {dir {}}} {
  88         if {$dir eq ""} {
  89                 set filename $name
  90         } else {
  91                 set filename $dir/$name
  92         }
  93         set f [open $filename w]
  94         puts $f $contents
  95         close $f
  96         return $filename
  97 }
  98
  99 proc makeDirectory {name} {
 100         file mkdir $name
 101         return $name
 102 }
 103
 104 proc temporaryDirectory {} {{dir {}}} {
 105         if {$dir eq ""} {
 106                 set dir [file join [env TMPDIR /tmp] [format "tcltmp-%04x" [rand 65536]]]
 107                 file mkdir $dir
 108         }
 109         return $dir
 110 }
 111
 112 proc removeFile {args} {
 113         file delete -force {*}$args
 114 }
 115
 116 proc removeDirectory {name} {
 117         file delete -force $name
 118 }
 119
 120 # In case tclcompat is not selected
 121 if {![exists -proc puts]} {
 122         proc puts {{-nonewline {}} {chan stdout} msg} {
 123                 if {${-nonewline} ni {-nonewline {}}} {
 124                         ${-nonewline} puts $msg
 125                 } else {
 126                         $chan puts {*}${-nonewline} $msg
 127                 }
 128         }
 129         proc close {chan args} {
 130                 $chan close {*}$args
 131         }
 132         proc fileevent {args} {
 133                 {*}$args
 134         }
 135 }
 136
 137 proc script_source {script} {
 138         lassign [info source $script] f l
 139         if {$f ne ""} {
 140                 puts "At      : $f:$l"
 141                 return \t$f:$l
 142         }
 143 }
 144
 145 proc error_source {} {
 146         lassign [info stacktrace] p f l
 147         if {$f ne ""} {
 148                 puts "At      : $f:$l"
 149                 return \t$f:$l
 150         }
 151 }
 152
 153 proc package-or-skip {name} {
 154         if {[catch {
 155                 package require $name
 156         }]} {
 157                 puts [format "%16s:   --- skipped" $::argv0]
 158                 exit 0
 159         }
 160 }
 161
 162 proc testConstraint {constraint {bool {}}} {
 163         if {$bool eq ""} {
 164                 if {[info exists ::tcltest::testConstraints($constraint)]} {
 165                         return $::tcltest::testConstraints($constraint)
 166                 }
 167                 return -code error "unknown constraint: $constraint"
 168                 return 1
 169         } else {
 170                 set ::tcltest::testConstraints($constraint) $bool
 171         }
 172 }
 173
 174 testConstraint {utf8} [expr {[string length "\xc2\xb5"] == 1}]
 175 testConstraint {references} [expr {[info commands getref] ne ""}]
 176 testConstraint {jim} 1
 177 testConstraint {tcl} 0
 178
 179 proc bytestring {x} {
 180         return $x
 181 }
 182
 183 # Note: We don't support -output or -errorOutput yet
 184 proc test {id descr args} {
 185         set a [dict create -returnCodes {ok return} -match exact -result {} -constraints {} -body {} -setup {} -cleanup {}]
 186         if {[lindex $args 0] ni [dict keys $a]} {
 187                 if {[llength $args] == 2} {
 188                         lassign $args body result constraints
 189                 } elseif {[llength $args] == 3} {
 190                         lassign $args constraints body result
 191                 } else {
 192                         return -code error "$id: Wrong syntax for tcltest::test v1"
 193                 }
 194                 tailcall test $id $descr -body $body -result $result -constraints $constraints
 195         }
 196         # tcltest::test v2 syntax
 197         array set a $args
 198
 199         incr ::testinfo(numtests)
 200         if {$::testinfo(verbose)} {
 201                 puts -nonewline "$id "
 202         }
 203
 204         foreach c $a(-constraints) {
 205                 if {![testConstraint $c]} {
 206                         incr ::testinfo(numskip)
 207                         if {$::testinfo(verbose)} {
 208                                 puts "SKIP $descr"
 209                         }
 210                         return
 211                 }
 212         }
 213
 214         if {[catch {uplevel 1 $a(-setup)} msg]} {
 215                 if {$::testinfo(verbose)} {
 216                         puts "-setup failed: $msg"
 217                 }
 218         }
 219         set rc [catch {uplevel 1 $a(-body)} result opts]
 220         if {[catch {uplevel 1 $a(-cleanup)} msg]} {
 221                 if {$::testinfo(verbose)} {
 222                         puts "-cleanup failed: $msg"
 223                 }
 224         }
 225
 226         if {[info return $rc] ni $a(-returnCodes) && $rc ni $a(-returnCodes)} {
 227                 set ok 0
 228                 set expected "rc=$a(-returnCodes) result=$a(-result)"
 229                 set result "rc=[info return $rc] result=$result"
 230         } else {
 231                 if {$a(-match) eq "exact"} {
 232                         set ok [string equal $a(-result) $result]
 233                 } elseif {$a(-match) eq "glob"} {
 234                         set ok [string match $a(-result) $result]
 235                 } elseif {$a(-match) eq "regexp"} {
 236                         set ok [regexp $a(-result) $result]
 237                 } else {
 238                         return -code error "$id: unknown match type: $a(-match)"
 239                 }
 240                 set expected $a(-result)
 241         }
 242
 243         if {$ok} {
 244                 if {$::testinfo(verbose)} {
 245                         puts "OK  $descr"
 246                 }
 247                 incr ::testinfo(numpass)
 248                 return
 249         }
 250
 251         if {!$::testinfo(verbose)} {
 252                 puts -nonewline "$id "
 253         }
 254         puts "ERR $descr"
 255         if {$rc in {0 2}} {
 256                 set source [script_source $a(-body)]
 257         } else {
 258                 set source [error_source]
 259         }
 260         puts "Expected: '$expected'"
 261         puts "Got     : '$result'"
 262         puts ""
 263         incr ::testinfo(numfail)
 264         lappend ::testinfo(failed) [list $id $descr $source $expected $result]
 265         if {$::testinfo(stoponerror)} {
 266                 exit 1
 267         }
 268 }
 269
 270 proc ::tcltest::cleanupTests {} {
 271         file delete [temporaryDirectory]
 272         tailcall testreport
 273 }
 274
 275 proc testreport {} {
 276         if {$::testinfo(reported)} {
 277                 return
 278         }
 279         incr ::testinfo(reported)
 280
 281         if {$::testinfo(verbose)} {
 282                 puts -nonewline "\n$::argv0"
 283         } else {
 284                 puts -nonewline [format "%16s" $::argv0]
 285         }
 286         puts [format ": Total %5d   Passed %5d  Skipped %5d  Failed %5d" \
 287                 $::testinfo(numtests) $::testinfo(numpass) $::testinfo(numskip) $::testinfo(numfail)]
 288         if {$::testinfo(numfail)} {
 289                 puts [string repeat - 60]
 290                 puts "FAILED: $::testinfo(numfail)"
 291                 foreach failed $::testinfo(failed) {
 292                         foreach {id descr source expected result} $failed {}
 293                         puts "$source\t$id"
 294                 }
 295                 puts [string repeat - 60]
 296         }
 297         if {$::testinfo(numfail)} {
 298                 exit 1
 299         }
 300 }
 301
 302 proc testerror {} {
 303         error "deliberate error"
 304 }
 305
 306 if {$testinfo(verbose)} {
 307         puts "==== $argv0 ===="
 308 }