Home | History | Annotate | Line # | Download | only in teaish
tester.tcl revision 1.1.1.1
      1 ########################################################################
      2 # 2025 April 5
      3 #
      4 # The author disclaims copyright to this source code.  In place of
      5 # a legal notice, here is a blessing:
      6 #
      7 #  * May you do good and not evil.
      8 #  * May you find forgiveness for yourself and forgive others.
      9 #  * May you share freely, never taking more than you give.
     10 #
     11 ########################################################################
     12 #
     13 # Helper routines for running tests on teaish extensions
     14 #
     15 ########################################################################
     16 # ----- @module teaish/tester.tcl -----
     17 #
     18 # @section TEA-ish Testing APIs.
     19 #
     20 # Though these are part of the autosup dir hierarchy, they are not
     21 # intended to be run from autosetup code. Rather, they're for use
     22 # with/via teaish.tester.tcl and target canonical Tcl only, not JimTcl
     23 # (which the autosetup pieces do target).
     24 
     25 #
     26 # @test-current-scope ?lvl?
     27 #
     28 # Returns the name of the _calling_ proc from ($lvl + 1) levels up the
     29 # call stack (where the caller's level will be 1 up from _this_
     30 # call). If $lvl would resolve to global scope "global scope" is
     31 # returned and if it would be negative then a string indicating such
     32 # is returned (as opposed to throwing an error).
     33 #
     34 proc test-current-scope {{lvl 0}} {
     35   #uplevel [expr {$lvl + 1}] {lindex [info level 0] 0}
     36   set ilvl [info level]
     37   set offset [expr {$ilvl  - $lvl - 1}]
     38   if { $offset < 0} {
     39     return "invalid scope ($offset)"
     40   } elseif { $offset == 0} {
     41     return "global scope"
     42   } else {
     43     return [lindex [info level $offset] 0]
     44   }
     45 }
     46 
     47 # @test-msg
     48 #
     49 # Emits all arugments to stdout.
     50 #
     51 proc test-msg {args} {
     52   puts "$args"
     53 }
     54 
     55 # @test-warn
     56 #
     57 # Emits all arugments to stderr.
     58 #
     59 proc test-warn {args} {
     60   puts stderr "WARNING: $args"
     61 }
     62 
     63 #
     64 # @test-error msg
     65 #
     66 # Triggers a test-failed error with a string describing the calling
     67 # scope and the provided message.
     68 #
     69 proc test-fail {args} {
     70   #puts stderr "ERROR: \[[test-current-scope 1]]: $msg"
     71   #exit 1
     72   error "FAIL: \[[test-current-scope 1]]: $args"
     73 }
     74 
     75 array set ::test__Counters {}
     76 array set ::test__Config {
     77   verbose-assert 0 verbose-affirm 0
     78 }
     79 
     80 # Internal impl for affirm and assert.
     81 #
     82 # $args = ?-v? script {msg-on-fail ""}
     83 proc test__affert {failMode args} {
     84   if {$failMode} {
     85     set what assert
     86   } else {
     87     set what affirm
     88   }
     89   set verbose $::test__Config(verbose-$what)
     90   if {"-v" eq [lindex $args 0]} {
     91     lassign $args - script msg
     92     if {1 == [llength $args]} {
     93       # If -v is the only arg, toggle default verbose mode
     94       set ::test__Config(verbose-$what) [expr {!$::test__Config(verbose-$what)}]
     95       return
     96     }
     97     incr verbose
     98   } else {
     99     lassign $args script msg
    100   }
    101   incr ::test__Counters($what)
    102   if {![uplevel 1 expr [list $script]]} {
    103     if {"" eq $msg} {
    104       set msg $script
    105     }
    106     set txt [join [list $what # $::test__Counters($what) "failed:" $msg]]
    107     if {$failMode} {
    108       puts stderr $txt
    109       exit 1
    110     } else {
    111       error $txt
    112     }
    113   } elseif {$verbose} {
    114     puts stderr [join [list $what # $::test__Counters($what) "passed:" $script]]
    115   }
    116 }
    117 
    118 #
    119 # @affirm ?-v? script ?msg?
    120 #
    121 # Works like a conventional assert method does, but reports failures
    122 # using [error] instead of [exit]. If -v is used, it reports passing
    123 # assertions to stderr. $script is evaluated in the caller's scope as
    124 # an argument to [expr].
    125 #
    126 proc affirm {args} {
    127   tailcall test__affert 0 {*}$args
    128 }
    129 
    130 #
    131 # @assert ?-v? script ?msg?
    132 #
    133 # Works like [affirm] but exits on error.
    134 #
    135 proc assert {args} {
    136   tailcall test__affert 1 {*}$args
    137 }
    138 
    139 #
    140 # @assert-matches ?-e? pattern ?-e? rhs ?msg?
    141 #
    142 # Equivalent to assert {[string match $pattern $rhs]} except that
    143 # if either of those are prefixed with an -e flag, they are eval'd
    144 # and their results are used.
    145 #
    146 proc assert-matches {args} {
    147   set evalLhs 0
    148   set evalRhs 0
    149   if {"-e" eq [lindex $args 0]} {
    150     incr evalLhs
    151     set args [lassign $args -]
    152   }
    153   set args [lassign $args pattern]
    154   if {"-e" eq [lindex $args 0]} {
    155     incr evalRhs
    156     set args [lassign $args -]
    157   }
    158   set args [lassign $args rhs msg]
    159 
    160   if {$evalLhs} {
    161     set pattern [uplevel 1 $pattern]
    162   }
    163   if {$evalRhs} {
    164     set rhs [uplevel 1 $rhs]
    165   }
    166   #puts "***pattern=$pattern\n***rhs=$rhs"
    167   tailcall test__affert 1 \
    168     [join [list \[ string match [list $pattern] [list $rhs] \]]] $msg
    169   # why does this not work? [list \[ string match [list $pattern] [list $rhs] \]] $msg
    170   # "\[string match [list $pattern] [list $rhs]\]"
    171 }
    172 
    173 #
    174 # @test-assert testId script ?msg?
    175 #
    176 # Works like [assert] but emits $testId to stdout first.
    177 #
    178 proc test-assert {testId script {msg ""}} {
    179   puts "test $testId"
    180   tailcall test__affert 1 $script $msg
    181 }
    182 
    183 #
    184 # @test-expect testId script result
    185 #
    186 # Runs $script in the calling scope and compares its result to
    187 # $result, minus any leading or trailing whitespace.  If they differ,
    188 # it triggers an [assert].
    189 #
    190 proc test-expect {testId script result} {
    191   puts "test $testId"
    192   set x [string trim [uplevel 1 $script]]
    193   set result [string trim $result]
    194   tailcall test__affert 0 [list "{$x}" eq "{$result}"] \
    195     "\nEXPECTED: <<$result>>\nGOT:      <<$x>>"
    196 }
    197 
    198 #
    199 # @test-catch cmd ?...args?
    200 #
    201 # Runs [cmd ...args], repressing any exception except to possibly log
    202 # the failure. Returns 1 if it caught anything, 0 if it didn't.
    203 #
    204 proc test-catch {cmd args} {
    205   if {[catch {
    206     uplevel 1 $cmd {*}$args
    207   } rc xopts]} {
    208     puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc"
    209     return 1
    210   }
    211   return 0
    212 }
    213 
    214 #
    215 # @test-catch-matching pattern (script|cmd args...)
    216 #
    217 # Works like test-catch, but it expects its argument(s) to to throw an
    218 # error matching the given string (checked with [string match]).  If
    219 # they do not throw, or the error does not match $pattern, this
    220 # function throws, else it returns 1.
    221 #
    222 # If there is no second argument, the $cmd is assumed to be a script,
    223 # and will be eval'd in the caller's scope.
    224 #
    225 # TODO: add -glob and -regex flags to control matching flavor.
    226 #
    227 proc test-catch-matching {pattern cmd args} {
    228   if {[catch {
    229     #puts "**** catch-matching cmd=$cmd args=$args"
    230     if {0 == [llength $args]} {
    231       uplevel 1 $cmd {*}$args
    232     } else {
    233       $cmd {*}$args
    234     }
    235   } rc xopts]} {
    236     if {[string match $pattern $rc]} {
    237       return 1
    238     } else {
    239       error "[test-current-scope] exception does not match {$pattern}: {$rc}"
    240     }
    241   }
    242   error "[test-current-scope] expecting to see an error matching {$pattern}"
    243 }
    244 
    245 if {![array exists ::teaish__BuildFlags]} {
    246   array set ::teaish__BuildFlags {}
    247 }
    248 
    249 #
    250 # @teaish-build-flag3 flag tgtVar ?dflt?
    251 #
    252 # If the current build has the configure-time flag named $flag set
    253 # then tgtVar is assigned its value and 1 is returned, else tgtVal is
    254 # assigned $dflt and 0 is returned.
    255 #
    256 # Caveat #1: only valid when called in the context of teaish's default
    257 # "make test" recipe, e.g. from teaish.test.tcl. It is not valid from
    258 # a teaish.tcl configure script because (A) the state it relies on
    259 # doesn't fully exist at that point and (B) that level of the API has
    260 # more direct access to the build state. This function requires that
    261 # an external script have populated its internal state, which is
    262 # normally handled via teaish.tester.tcl.in.
    263 #
    264 # Caveat #2: defines in the style of HAVE_FEATURENAME with a value of
    265 # 0 are, by long-standing configure script conventions, treated as
    266 # _undefined_ here.
    267 #
    268 proc teaish-build-flag3 {flag tgtVar {dflt ""}} {
    269   upvar $tgtVar tgt
    270   if {[info exists ::teaish__BuildFlags($flag)]} {
    271     set tgt $::teaish__BuildFlags($flag)
    272     return 1;
    273   } elseif {0==[array size ::teaish__BuildFlags]} {
    274     test-warn \
    275       "\[[test-current-scope]] was called from " \
    276       "[test-current-scope 1] without the build flags imported."
    277   }
    278   set tgt $dflt
    279   return 0
    280 }
    281 
    282 #
    283 # @teaish-build-flag flag ?dflt?
    284 #
    285 # Convenience form of teaish-build-flag3 which returns the
    286 # configure-time-defined value of $flag or "" if it's not defined (or
    287 # if it's an empty string).
    288 #
    289 proc teaish-build-flag {flag {dflt ""}} {
    290   set tgt ""
    291   teaish-build-flag3 $flag tgt $dflt
    292   return $tgt
    293 }
    294