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