/home/mrjunejune/zenbu: third_party/sqlite3/autosetup/teaish/tester.tcl comparison

comparison third_party/sqlite3/autosetup/teaish/tester.tcl @ 167:589bab390fb4

[ThirdParty] Added sqlite3 to the third_party.

author	MrJuneJune <me@mrjunejune.com>
date	Mon, 19 Jan 2026 16:28:45 -0800
parents
children

comparison

equal deleted inserted replaced

-:78ea8d5ccc87
+:589bab390fb4
+########################################################################
+# 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 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
+}
+#
+# @assert-matches ?-e? pattern ?-e? rhs ?msg?
+#
+# Equivalent to assert {[string match $pattern $rhs]} except that
+# if either of those are prefixed with an -e flag, they are eval'd
+# and their results are used.
+#
+proc assert-matches {args} {
+set evalLhs 0
+set evalRhs 0
+if {"-e" eq [lindex $args 0]} {
+incr evalLhs
+set args [lassign $args -]
+}
+set args [lassign $args pattern]
+if {"-e" eq [lindex $args 0]} {
+incr evalRhs
+set args [lassign $args -]
+}
+set args [lassign $args rhs msg]
+if {$evalLhs} {
+set pattern [uplevel 1 $pattern]
+}
+if {$evalRhs} {
+set rhs [uplevel 1 $rhs]
+}
+#puts "***pattern=$pattern\n***rhs=$rhs"
+tailcall test__affert 1 \
+[join [list \[ string match [list $pattern] [list $rhs] \]]] $msg
+# why does this not work? [list \[ string match [list $pattern] [list $rhs] \]] $msg
+# "\[string match [list $pattern] [list $rhs]\]"
+}
+#
+# @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 {
+uplevel 1 $cmd {*}$args
+} rc xopts]} {
+puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc"
+return 1
+}
+return 0
+}
+#
+# @test-catch-matching pattern (script|cmd args...)
+#
+# Works like test-catch, but it expects its argument(s) to to throw an
+# error matching the given string (checked with [string match]).  If
+# they do not throw, or the error does not match $pattern, this
+# function throws, else it returns 1.
+#
+# If there is no second argument, the $cmd is assumed to be a script,
+# and will be eval'd in the caller's scope.
+#
+# TODO: add -glob and -regex flags to control matching flavor.
+#
+proc test-catch-matching {pattern cmd args} {
+if {[catch {
+#puts "**** catch-matching cmd=$cmd args=$args"
+if {0 == [llength $args]} {
+uplevel 1 $cmd {*}$args
+} else {
+$cmd {*}$args
+}
+} rc xopts]} {
+if {[string match $pattern $rc]} {
+return 1
+} else {
+error "[test-current-scope] exception does not match {$pattern}: {$rc}"
+}
+}
+error "[test-current-scope] expecting to see an error matching {$pattern}"
+}
+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
+}

Mercurial

comparison third_party/sqlite3/autosetup/teaish/tester.tcl @ 167:589bab390fb4