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