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