diff options
Diffstat (limited to 'autosetup/teaish/tester.tcl')
| -rw-r--r-- | autosetup/teaish/tester.tcl | 228 |
1 files changed, 228 insertions, 0 deletions
diff --git a/autosetup/teaish/tester.tcl b/autosetup/teaish/tester.tcl new file mode 100644 index 000000000..d8b5f7a0e --- /dev/null +++ b/autosetup/teaish/tester.tcl @@ -0,0 +1,228 @@ +######################################################################## +# 2025 April 5 +# +# The author disclaims copyright to this source code. In place of +# a legal notice, here is a blessing: +# +# * May you do good and not evil. +# * May you find forgiveness for yourself and forgive others. +# * May you share freely, never taking more than you give. +# +######################################################################## +# +# Helper routines for running tests on teaish extensions +# +######################################################################## +# ----- @module teaish/tester.tcl ----- +# +# @section TEA-ish Testing APIs. +# +# Though these are part of the autosup dir hierarchy, they are not +# intended to be run from autosetup code. Rather, they're for use +# with/via teaish.tester.tcl and target canonical Tcl only, not JimTcl +# (which the autosetup pieces do target). + +# +# @test-current-scope ?lvl? +# +# Returns the name of the _calling_ proc from ($lvl + 1) levels up the +# call stack (where the caller's level will be 1 up from _this_ +# call). If $lvl would resolve to global scope "global scope" is +# returned and if it would be negative then a string indicating such +# is returned (as opposed to throwing an error). +# +proc test-current-scope {{lvl 0}} { + #uplevel [expr {$lvl + 1}] {lindex [info level 0] 0} + set ilvl [info level] + set offset [expr {$ilvl - $lvl - 1}] + if { $offset < 0} { + return "invalid scope ($offset)" + } elseif { $offset == 0} { + return "global scope" + } else { + return [lindex [info level $offset] 0] + } +} + +# @test-msg +# +# Emits all arugments to stdout. +# +proc test-msg {args} { + puts "$args" +} + +# @test-warn +# +# Emits all arugments to stderr. +# +proc test-warn {args} { + puts stderr "WARNING: $args" +} + +# +# @test-error msg +# +# Triggers a test-failed error with a string describing the calling +# scope and the provided message. +# +proc test-fail {args} { + #puts stderr "ERROR: \[[test-current-scope 1]]: $msg" + #exit 1 + error "FAIL: \[[test-current-scope 1]]: $args" +} + +array set ::test__Counters {} +array set ::test__Config { + verbose-assert 0 verbose-affirm 0 +} + +# Internal impl for affirm and assert. +# +# $args = ?-v? script {msg-on-fail ""} +proc test__affert {failMode args} { + if {$failMode} { + set what assert + } else { + set what affirm + } + set verbose $::test__Config(verbose-$what) + if {"-v" eq [lindex $args 0]} { + lassign $args - script msg + if {1 == [llength $args]} { + # If -v is the only arg, toggle default verbose mode + set ::test__Config(verbose-$what) [expr {!$::test__Config(verbose-$what)}] + return + } + incr verbose + } else { + lassign $args script msg + } + incr ::test__Counters($what) + if {![uplevel 1 [concat expr [list $script]]]} { + if {"" eq $msg} { + set msg $script + } + set txt [join [list $what # $::test__Counters($what) "failed:" $msg]] + if {$failMode} { + puts stderr $txt + exit 1 + } else { + error $txt + } + } elseif {$verbose} { + puts stderr [join [list $what # $::test__Counters($what) "passed:" $script]] + } +} + +# +# @affirm ?-v? script ?msg? +# +# Works like a conventional assert method does, but reports failures +# using [error] instead of [exit]. If -v is used, it reports passing +# assertions to stderr. $script is evaluated in the caller's scope as +# an argument to [expr]. +# +proc affirm {args} { + tailcall test__affert 0 {*}$args +} + +# +# @assert ?-v? script ?msg? +# +# Works like [affirm] but exits on error. +# +proc assert {args} { + tailcall test__affert 1 {*}$args +} + +# +# @test-assert testId script ?msg? +# +# Works like [assert] but emits $testId to stdout first. +# +proc test-assert {testId script {msg ""}} { + puts "test $testId" + tailcall test__affert 1 $script $msg +} + +# +# @test-expect testId script result +# +# Runs $script in the calling scope and compares its result to +# $result, minus any leading or trailing whitespace. If they differ, +# it triggers an [assert]. +# +proc test-expect {testId script result} { + puts "test $testId" + set x [string trim [uplevel 1 $script]] + set result [string trim $result] + tailcall test__affert 0 [list $x eq $result] \ + "\nEXPECTED: <<$result>>\nGOT: <<$x>>" +} + +# +# @test-catch cmd ?...args? +# +# Runs [cmd ...args], repressing any exception except to possibly log +# the failure. Returns 1 if it caught anything, 0 if it didn't. +# +proc test-catch {cmd args} { + if {[catch { + $cmd {*}$args + } rc xopts]} { + puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc" + return 1 + } + return 0 +} + +if {![array exists ::teaish__BuildFlags]} { + array set ::teaish__BuildFlags {} +} + +# +# @teaish-build-flag3 flag tgtVar ?dflt? +# +# If the current build has the configure-time flag named $flag set +# then tgtVar is assigned its value and 1 is returned, else tgtVal is +# assigned $dflt and 0 is returned. +# +# Caveat #1: only valid when called in the context of teaish's default +# "make test" recipe, e.g. from teaish.test.tcl. It is not valid from +# a teaish.tcl configure script because (A) the state it relies on +# doesn't fully exist at that point and (B) that level of the API has +# more direct access to the build state. This function requires that +# an external script have populated its internal state, which is +# normally handled via teaish.tester.tcl.in. +# +# Caveat #2: defines in the style of HAVE_FEATURENAME with a value of +# 0 are, by long-standing configure script conventions, treated as +# _undefined_ here. +# +proc teaish-build-flag3 {flag tgtVar {dflt ""}} { + upvar $tgtVar tgt + if {[info exists ::teaish__BuildFlags($flag)]} { + set tgt $::teaish__BuildFlags($flag) + return 1; + } elseif {0==[array size ::teaish__BuildFlags]} { + test-warn \ + "\[[test-current-scope]] was called from " \ + "[test-current-scope 1] without the build flags imported." + } + set tgt $dflt + return 0 +} + +# +# @teaish-build-flag flag ?dflt? +# +# Convenience form of teaish-build-flag3 which returns the +# configure-time-defined value of $flag or "" if it's not defined (or +# if it's an empty string). +# +proc teaish-build-flag {flag {dflt ""}} { + set tgt "" + teaish-build-flag3 $flag tgt $dflt + return $tgt +} |