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