Adding the sqlite sourcecode
This commit is contained in:
Jiří Stach committed
1 parent
bdb54a1f8f
commit
406b584760
2208 files changed
+1172785
-1
No files matched your search
@@ -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
|
||||
}
|
||||
Reference in new issue
Block a user