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