diff options
Diffstat (limited to 'autosetup')
| -rw-r--r-- | autosetup/proj.tcl | 492 | ||||
| -rw-r--r-- | autosetup/sqlite-config.tcl | 61 | ||||
| -rw-r--r-- | autosetup/teaish/core.tcl | 137 | ||||
| -rw-r--r-- | autosetup/teaish/tester.tcl | 71 |
4 files changed, 567 insertions, 194 deletions
diff --git a/autosetup/proj.tcl b/autosetup/proj.tcl index 133556706..5cebc0472 100644 --- a/autosetup/proj.tcl +++ b/autosetup/proj.tcl @@ -60,10 +60,11 @@ # $proj__Config is an internal-use-only array for storing whatever generic # internal stuff we need stored. # -array set ::proj__Config { - self-tests 1 -} - +array set ::proj__Config [subst { + self-tests [get-env proj.self-tests 0] + verbose-assert [get-env proj.assert-verbose 0] + isatty [isatty? stdout] +}] # # List of dot-in files to filter in the final stages of @@ -75,7 +76,6 @@ array set ::proj__Config { # See: proj-dot-ins-append and proj-dot-ins-process # set ::proj__Config(dot-in-files) [list] -set ::proj__Config(isatty) [isatty? stdout] # # @proj-warn msg @@ -85,28 +85,29 @@ set ::proj__Config(isatty) [isatty? stdout] # proc proj-warn {args} { show-notices - puts stderr [join [list "WARNING: \[[proj-scope 1]\]: " {*}$args] " "] + puts stderr [join [list "WARNING:" \[ [proj-scope 1] \]: {*}$args] " "] } +# # Internal impl of [proj-fatal] and [proj-error]. It must be called # using tailcall. -proc proj__faterr {failMode argv} { +# +proc proj__faterr {failMode args} { show-notices set lvl 1 - while {"-up" eq [lindex $argv 0]} { - set argv [lassign $argv -] + while {"-up" eq [lindex $args 0]} { + set args [lassign $args -] incr lvl } if {$failMode} { - puts stderr [join [list "FATAL: \[[proj-scope $lvl]]: " {*}$argv]] + puts stderr [join [list "FATAL:" \[ [proj-scope $lvl] \]: {*}$args]] exit 1 } else { - error [join [list "\[[proj-scope $lvl]]:" {*}$argv]] + error [join [list in \[ [proj-scope $lvl] \]: {*}$args]] } } - # # @proj-fatal ?-up...? msg... # @@ -118,7 +119,7 @@ proc proj__faterr {failMode argv} { # additional level. # proc proj-fatal {args} { - tailcall proj__faterr 1 $args + tailcall proj__faterr 1 {*}$args } # @@ -127,10 +128,9 @@ proc proj-fatal {args} { # Works like proj-fatal but uses [error] intead of [exit]. # proc proj-error {args} { - tailcall proj__faterr 0 $args + tailcall proj__faterr 0 {*}$args } -set ::proj__Config(verbose-assert) [get-env proj-assert-verbose 0] # # @proj-assert script ?message? # @@ -147,7 +147,7 @@ proc proj-assert {script {msg ""}} { if {"" eq $msg} { set msg $script } - proj-fatal "Assertion failed in \[[proj-scope 1]\]: $msg" + tailcall proj__faterr 1 "Assertion failed:" $msg } } @@ -885,7 +885,9 @@ proc proj-looks-like-windows {{key host}} { # proc proj-looks-like-mac {{key host}} { switch -glob -- [get-define $key] { - *apple* { + *-*-darwin* { + # https://sqlite.org/forum/forumpost/7b218c3c9f207646 + # There's at least one Linux out there which matches *apple*. return 1 } default { @@ -927,17 +929,13 @@ proc proj-exe-extension {} { # proc proj-dll-extension {} { set inner {{key} { - switch -glob -- [get-define $key] { - *apple* { - return ".dylib" - } - *-*-ming* - *-*-cygwin - *-*-msys { - return ".dll" - } - default { - return ".so" - } + if {[proj-looks-like-mac $key]} { + return ".dylib" + } + if {[proj-looks-like-windows $key]} { + return ".dll" } + return ".so" }} define BUILD_DLLEXT [apply $inner build] define TARGET_DLLEXT [apply $inner host] @@ -1665,7 +1663,7 @@ proc proj-dot-ins-append {fileIn args} { proj-fatal "Too many arguments: $fileIn $args" } } - #puts "******* [proj-scope]: adding $fileIn" + #puts "******* [proj-scope]: adding [llength $fileIn]-length item: $fileIn" lappend ::proj__Config(dot-in-files) $fileIn } @@ -1703,17 +1701,18 @@ proc proj-dot-ins-list {} { # makes proj-dot-ins-append available for re-use. # proc proj-dot-ins-process {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -touch "" {return "-touch"} -clear 0 {expr 1} -validate 0 {expr 1} } + #puts "args=$args"; parray flags if {[llength $args] > 0} { error "Invalid argument to [proj-scope]: $args" } foreach f $::proj__Config(dot-in-files) { proj-assert {3==[llength $f]} \ - "Expecting proj-dot-ins-list to be stored in 3-entry lists" + "Expecting proj-dot-ins-list to be stored in 3-entry lists. Got: $f" lassign $f fIn fOut fScript #puts "DOING $fIn ==> $fOut" proj-make-from-dot-in {*}$flags(-touch) $fIn $fOut @@ -1753,7 +1752,7 @@ proc proj-validate-no-unresolved-ats {args} { set isMake [string match {*[Mm]ake*} $f] foreach line [proj-file-content-list $f] { if {!$isMake || ![string match "#*" [string trimleft $line]]} { - if {[regexp {(@[A-Za-z0-9_]+@)} $line match]} { + if {[regexp {(@[A-Za-z0-9_\.]+@)} $line match]} { error "Unresolved reference to $match at line $lnno of $f" } } @@ -1893,7 +1892,7 @@ proc proj-define-amend {args} { # proc proj-define-to-cflag {args} { set rv {} - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -list 0 {expr 1} -quote 0 {expr 1} -zero-undef 0 {expr 1} @@ -2001,7 +2000,7 @@ proc proj-cache-key {arg {addLevel 0}} { # See proj-cache-key for -key's and -level's semantics, noting that # this function adds one to -level for purposes of that call. proc proj-cache-set {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -key => 0 -level => 0 } @@ -2037,7 +2036,7 @@ proc proj-cache-remove {{key 0} {addLevel 0}} { # See proj-cache-key for $key's and $addLevel's semantics, noting that # this function adds one to $addLevel for purposes of that call. proc proj-cache-check {args} { - proj-parse-simple-flags args flags { + proj-parse-flags args flags { -key => 0 -level => 0 } @@ -2070,147 +2069,316 @@ proc proj-coalesce {args} { } # -# @proj-parse-simple-flags ... +# @proj-parse-flags argvListName targetArrayName {prototype} # # A helper to parse flags from proc argument lists. # -# Expects a list of arguments to parse, an array name to store any -# -flag values to, and a prototype object which declares the flags. +# The first argument is the name of a var holding the args to +# parse. It will be overwritten, possibly with a smaller list. # -# The prototype must be a list in one of the following forms: +# The second argument is the name of an array variable to create in +# the caller's scope. # -# -flag defaultValue {script} +# The third argument, $prototype, is a description of how to handle +# the flags. Each entry in that list must be in one of the +# following forms: # -# -flag => defaultValue -# -----^--^ (with spaces there!) +# -flag defaultValue ?-literal|-call|-apply? +# script|number|incr|proc-name|{apply $aLambda} # -# Repeated for each flag. +# -flag* ...as above... # -# The first form represents a basic flag with no associated -# following argument. The second form extracts its value -# from the following argument in $argvName. +# -flag => defaultValue ?-call proc-name-and-args|-apply lambdaExpr? # -# The first argument to this function is the name of a var holding the -# args to parse. It will be overwritten, possibly with a smaller list. +# -flag* => ...as above... # -# The second argument the name of an array variable to create in the -# caller's scope. (Pneumonic: => points to the next argument.) +# :PRAGMA # -# For the first form of flag, $script is run in the caller's scope if -# $argv contains -flag, and the result of that script is the new value -# for $tgtArrayName(-flag). This function intercepts [return $val] -# from $script. Any empty script will result in the flag having "" -# assigned to it. +# The first two forms represents a basic flag with no associated +# following argument. The third and fourth forms, called arg-consuming +# flags, extract the value from the following argument in $argvName +# (pneumonic: => points to the next argument.). The :PRAGMA form +# offers a way to configure certain aspects of this call. # -# The args list is only inspected until the first argument which is -# not described by $prototype. i.e. the first "non-flag" (not counting -# values consumed for flags defined like --flag=>default). +# If $argv contains any given flag from $prototype, its default value +# is overridden depending on several factors: # -# If a "--" flag is encountered, no more arguments are inspected as -# flags. If "--" is the first non-flag argument, the "--" flag is -# removed from the results but all remaining arguments are passed -# through. If "--" appears after the first non-flag, it is retained. +# - If the -literal flag is used, or the flag's script is a number, +# value is used verbatim. +# +# - Else if the -call flag is used, the argument must be a proc name +# and any leading arguments, e.g. {apply $myLambda}. The proc is passed +# the (flag, value) as arguments (non-consuming flags will get +# passed the flag's current/starting value and consuming flags will +# get the next argument). Its result becomes the result of the +# flag. +# +# - Else if -apply X is used, it's effectively shorthand for -call +# {apply X}. Its argument may either be a $lambaRef or a {{f v} +# {body}} construct. +# +# - Else if $script is one of the following values, it is treated as +# the result of... +# +# - incr: increments the current value of the flag. +# +# - Else $script is eval'd to get its result value. That result +# becomes the new flag value for $tgtArrayName(-flag). This +# function intercepts [return $val] from eval'ing $script. Any +# empty script will result in the flag having "" assigned to it. # -# This function assumes that each flag is unique, and using a flag -# more than once behaves in a last-one-wins fashion. +# Unless the -flag has a trailing asterisk, e.g. -flag*, this function +# assumes that each flag is unique, and using a flag more than once +# causes an error to be triggered. the -flag* forms works similarly +# except that may appear in $argv any number of times: # -# Any argvName entries not described in $prototype are not treated as -# flags. +# - For non-arg-consuming flags, each invocation of -flag causes the +# result of $script to overwrite the previous value. e.g. so +# {-flag* {x} {incr foo}} has a default value of x, but passing in +# -flag twice would change it to the result of incrementing foo +# twice. This form can be used to implement, e.g., increasing +# verbosity levels by passing -verbose multiple times. # -# Returns the number of flags it processed in $argvName. +# - For arg-consuming flags, the given flag starts with value X, but +# if the flag is provided in $argv, the default is cleared, then +# each instance of -flag causes its value to be appended to the +# result, so {-flag* => {a b c}} defaults to {a b c}, but passing +# in -flag y -flag z would change it to {y z}, not {a b c y z}.. +# +# By default, the args list is only inspected until the first argument +# which is not described by $prototype. i.e. the first "non-flag" (not +# counting values consumed for flags defined like -flag => default). +# The :all-flags pragma (see below) can modify this behavior. +# +# If a "--" flag is encountered, no more arguments are inspected as +# flags unless the :all-flags pragma (see below) is in effect. The +# first instance of "--" is removed from the target result list but +# all remaining instances of "--" are are passed through. +# +# Any argvName entries not described in $prototype are considered to +# be "non-flags" for purposes of this function, even if they +# ostensibly look like flags. +# +# Returns the number of flags it processed in $argvName, not counting +# "--". # # Example: # -# set args [list -foo -bar {blah} 8 9 10 -theEnd] -# proj-parse-simple-flags args flags { -# -foo 0 {expr 1} -# -bar => 0 -# -no-baz 2 {return 0} -# } +## set args [list -foo -bar {blah} -z 8 9 10 -theEnd] +## proj-parse-flags args flags { +## -foo 0 {expr 1} +## -bar => 0 +## -no-baz 1 {return 0} +## -z 0 2 +## } # -# After that $flags would contain {-foo 1 -bar {blah} -no-baz 2} +# After that $flags would contain {-foo 1 -bar {blah} -no-baz 1 -z 2} # and $args would be {8 9 10 -theEnd}. # -# Potential TODOs: consider using lappend instead of set so that any -# given flag can be used more than once. Or add a syntax to indicate -# that multiples are allowed. Also consider searching the whole -# argv list, rather than stopping at the first non-flag +# Pragmas: # -proc proj-parse-simple-flags {argvName tgtArrayName prototype} { +# Passing :PRAGMAS to this function may modify how it works. The +# following pragmas are supported (note the leading ":"): +# +# :all-flags indicates that the whole input list should be scanned, +# not stopping at the first non-flag or "--". +# +proc proj-parse-flags {argvName tgtArrayName prototype} { upvar $argvName argv - upvar $tgtArrayName tgt - array set dflt {} - array set scripts {} - array set consuming {} + upvar $tgtArrayName outFlags + array set flags {}; # staging area + array set blob {}; # holds markers for various per-key state and options + set incrSkip 1; # 1 if we stop at the first non-flag, else 0 + # Parse $prototype for flag definitions... set n [llength $prototype] - # Figure out what our flags are... + set checkProtoFlag { + #puts "**** checkProtoFlag #$i of $n k=$k fv=$fv" + switch -exact -- $fv { + -literal { + proj-assert {![info exists blob(${k}.consumes)]} + set blob(${k}.script) [list expr [lindex $prototype [incr i]]] + } + -apply { + set fv [lindex $prototype [incr i]] + if {2 == [llength $fv]} { + # Treat this as a lambda literal + set fv [list $fv] + } + lappend blob(${k}.call) "apply $fv" + } + -call { + # arg is either a proc name or {apply $aLambda} + set fv [lindex $prototype [incr i]] + lappend blob(${k}.call) $fv + } + default { + proj-assert {![info exists blob(${k}.consumes)]} + set blob(${k}.script) $fv + } + } + if {$i >= $n} { + proj-error -up "[proj-scope]: Missing argument for $k flag" + } + } for {set i 0} {$i < $n} {incr i} { set k [lindex $prototype $i] #puts "**** #$i of $n k=$k" + + # Check for :PRAGMA... + switch -exact -- $k { + :all-flags { + set incrSkip 0 + continue + } + } + proj-assert {[string match -* $k]} \ - "Invalid flag value: $k" - set v "" - set s "" + "Invalid argument: $k" + + if {[string match {*\*} $k]} { + # Re-map -foo* to -foo and flag -foo as a repeatable flag + set k [string map {* ""} $k] + incr blob(${k}.multi) + } + + if {[info exists flags($k)]} { + proj-error -up "[proj-scope]: Duplicated prototype for flag $k" + } + switch -exact -- [lindex $prototype [expr {$i + 1}]] { => { + # -flag => DFLT ?-subflag arg? incr i 2 if {$i >= $n} { - proj-error "Missing argument for $k => flag" + proj-error -up "[proj-scope]: Missing argument for $k => flag" + } + incr blob(${k}.consumes) + set vi [lindex $prototype $i] + if {$vi in {-apply -call}} { + proj-error -up "[proj-scope]: Missing default value for $k flag" + } else { + set fv [lindex $prototype [expr {$i + 1}]] + if {$fv in {-apply -call}} { + incr i + eval $checkProtoFlag + } } - set consuming($k) 1 - set v [lindex $prototype $i] } default { - set v [lindex $prototype [incr i]] - set s [lindex $prototype [incr i]] - set scripts($k) $s + # -flag VALUE ?flag? SCRIPT + set vi [lindex $prototype [incr i]] + set fv [lindex $prototype [incr i]] + eval $checkProtoFlag } } - #puts "**** #$i of $n k=$k v=$v s=$s" - set dflt($k) $v + #puts "**** #$i of $n k=$k vi=$vi" + set flags($k) $vi } - # Now look for those flags in the source list - array set tgt [array get dflt] - unset dflt + #puts "-- flags"; parray flags + #puts "-- blob"; parray blob set rc 0 - set rv {} + set rv {}; # staging area for the target argv value set skipMode 0 set n [llength $argv] + # Now look for those flags in $argv... for {set i 0} {$i < $n} {incr i} { set arg [lindex $argv $i] + #puts "-- [proj-scope] arg=$arg" if {$skipMode} { lappend rv $arg } elseif {"--" eq $arg} { - incr skipMode - } elseif {[info exists tgt($arg)]} { - if {[info exists consuming($arg)]} { - if {$i + 1 >= $n} { - proj-assert 0 {Cannot happen - bounds already checked} + # "--" is the conventional way to end processing of args + if {[incr blob(--)] > 1} { + # Elide only the first one + lappend rv $arg + } + incr skipMode $incrSkip + } elseif {[info exists flags($arg)]} { + # A known flag... + set isMulti [info exists blob(${arg}.multi)] + incr blob(${arg}.seen) + if {1 < $blob(${arg}.seen) && !$isMulti} { + proj-error -up [proj-scope] "$arg flag was used multiple times" + } + set vMode 0; # 0=as-is, 1=eval, 2=call + set isConsuming [info exists blob(${arg}.consumes)] + if {$isConsuming} { + incr i + if {$i >= $n} { + proj-error -up [proj-scope] "is missing argument for $arg flag" } - set tgt($arg) [lindex $argv [incr i]] - } elseif {"" eq $scripts($arg)} { - set tgt($arg) "" + set vv [lindex $argv $i] + } elseif {[info exists blob(${arg}.script)]} { + set vMode 1 + set vv $blob(${arg}.script) } else { - #puts "**** running scripts($arg) $scripts($arg)" - set code [catch {uplevel 1 $scripts($arg)} xrc xopt] - #puts "**** tgt($arg)=$scripts($arg) code=$code rc=$rc" - if {$code in {0 2}} { - set tgt($arg) $xrc + set vv $flags($arg) + } + + if {[info exists blob(${arg}.call)]} { + set vMode 2 + set vv [concat {*}$blob(${arg}.call) $arg $vv] + } elseif {$isConsuming} { + proj-assert {!$vMode} + # fall through + } elseif {"" eq $vv || [string is double -strict $vv]} { + set vMode 0 + } elseif {$vv in {incr}} { + set vMode 0 + switch -exact $vv { + incr { + set xx $flags($k); incr xx; set vv $xx; unset xx + } + default { + proj-error "Unhandled \$vv value $vv" + } + } + } else { + set vv [list eval $vv] + set vMode 1 + } + if {$vMode} { + set code [catch [list uplevel 1 $vv] vv xopt] + if {$code ni {0 2}} { + return {*}$xopt $vv + } + } + if {$isConsuming && $isMulti} { + if {1 == $blob(${arg}.seen)} { + # On the first hit, overwrite the default with a new list. + set flags($arg) [list $vv] } else { - return {*}$xopt $xrc + # On subsequent hits, append to the list. + lappend flags($arg) $vv } + } else { + set flags($arg) $vv } incr rc } else { - incr skipMode + # Non-flag + incr skipMode $incrSkip lappend rv $arg } } set argv $rv + array set outFlags [array get flags] + #puts "-- rv=$rv argv=$argv flags="; parray flags return $rc +}; # proj-parse-flags + +# +# Older (deprecated) name of proj-parse-flags. +# +proc proj-parse-simple-flags {args} { + tailcall proj-parse-flags {*}$args } if {$::proj__Config(self-tests)} { + set __ova $::proj__Config(verbose-assert); + set ::proj__Config(verbose-assert) 1 + puts "Running [info script] self-tests..." + # proj-cache... apply {{} { #proj-warn "Test code for proj-cache" proj-assert {![proj-cache-check -key here check]} @@ -2233,4 +2401,100 @@ if {$::proj__Config(self-tests)} { proj-assert {"" eq [proj-cache-remove]} proj-assert {"" eq $check} }} -} + + # proj-parse-flags ... + apply {{} { + set foo 3 + set argv {-a "hi - world" -b -b -b -- -a {bye bye} -- -d -D c -a "" --} + proj-parse-flags argv flags { + :all-flags + -a* => "gets overwritten" + -b* 7 {incr foo} + -d 1 0 + -D 0 1 + } + + #puts "-- argv = $argv"; parray flags; + proj-assert {"-- c --" eq $argv} + proj-assert {$flags(-a) eq "{hi - world} {bye bye} {}"} + proj-assert {$foo == 6} + proj-assert {$flags(-b) eq $foo} + proj-assert {$flags(-d) == 0} + proj-assert {$flags(-D) == 1} + set foo 0 + foreach x $flags(-a) { + proj-assert {$x in {{hi - world} {bye bye} {}}} + incr foo + } + proj-assert {3 == $foo} + + set argv {-a {hi world} -b -maybe -- -a {bye bye} -- -b c --} + set foo 0 + proj-parse-flags argv flags { + -a => "aaa" + -b 0 {incr foo} + -maybe no -literal yes + } + #parray flags; puts "--- argv = $argv" + proj-assert {"-a {bye bye} -- -b c --" eq $argv} + proj-assert {$flags(-a) eq "hi world"} + proj-assert {1 == $flags(-b)} + proj-assert {"yes" eq $flags(-maybe)} + + set argv {-f -g -a aaa -M -M -M -L -H -A AAA a b c} + set foo 0 + set myLambda {{flag val} { + proj-assert {$flag in {-f -g -M}} + #puts "myLambda flag=$flag val=$val" + incr val + }} + proc myNonLambda {flag val} { + proj-assert {$flag in {-A -a}} + #puts "myNonLambda flag=$flag val=$val" + concat $val $val + } + proj-parse-flags argv flags { + -f 0 -call {apply $myLambda} + -g 2 -apply $myLambda + -h 3 -apply $myLambda + -H 30 33 + -a => aAAAa -apply {{f v} { + set v + }} + -A => AaaaA -call myNonLambda + -B => 17 -call myNonLambda + -M* 0 -apply $myLambda + -L "" -literal $myLambda + } + rename myNonLambda "" + #puts "--- argv = $argv"; parray flags + proj-assert {$flags(-f) == 1} + proj-assert {$flags(-g) == 3} + proj-assert {$flags(-h) == 3} + proj-assert {$flags(-H) == 33} + proj-assert {$flags(-a) == {aaa}} + proj-assert {$flags(-A) eq "AAA AAA"} + proj-assert {$flags(-B) == 17} + proj-assert {$flags(-M) == 3} + proj-assert {$flags(-L) eq $myLambda} + + set argv {-touch -validate} + proj-parse-flags argv flags { + -touch "" {return "-touch"} + -validate 0 1 + } + #puts "----- argv = $argv"; parray flags + proj-assert {$flags(-touch) eq "-touch"} + proj-assert {$flags(-validate) == 1} + proj-assert {$argv eq {}} + + set argv {-i -i -i} + proj-parse-flags argv flags { + -i* 0 incr + } + proj-assert {3 == $flags(-i)} + }} + set ::proj__Config(verbose-assert) $__ova + unset __ova + puts "Done running [info script] self-tests." +}; # proj- API self-tests diff --git a/autosetup/sqlite-config.tcl b/autosetup/sqlite-config.tcl index 1df6e233f..4dd065095 100644 --- a/autosetup/sqlite-config.tcl +++ b/autosetup/sqlite-config.tcl @@ -217,6 +217,11 @@ proc sqlite-configure {buildMode configScript} { => {This legacy flag has no effect on the library but may influence the generated sqlite_cfg.h by adding #define HAVE_LFS} } + {canonical} { + column-metadata => {Enable the column metadata APIs} + # ^^^ Affects how sqlite3.c is generated, so is not available in + # the autoconf build. + } } # Options for TCL support @@ -227,8 +232,6 @@ proc sqlite-configure {buildMode configScript} { This tree requires TCL for code generation but can use the in-tree copy of autosetup/jimsh0.c for that. The SQLite TCL extension and the test code require a canonical tclsh.} - } - {canonical} { with-tcl:DIR => {Directory containing tclConfig.sh or a directory one level up from that, from which we can derive a directory containing tclConfig.sh. @@ -236,11 +239,10 @@ proc sqlite-configure {buildMode configScript} { the --prefix flag.} with-tclsh:PATH => {Full pathname of tclsh to use. It is used for (A) trying to find - tclConfig.sh and (B) all TCL-based code generation. Warning: if - its containing dir has multiple tclsh versions, it may select the + tclConfig.sh and (B) all TCL-based code generation. Use --with-tcl + unless you have a specific need for this flag. Warning: if its + containing dir has multiple tclsh versions, it may select the wrong tclConfig.sh!} - } - {canonical} { static-tclsqlite3=0 => {Statically-link tclsqlite3. This only works if TCL support is enabled and all requisite libraries are available in @@ -334,8 +336,8 @@ proc sqlite-configure {buildMode configScript} { => {Link the sqlite3 shell app against the DLL instead of embedding sqlite3.c} } {canonical autoconf} { - # A potential TODO without a current use case: - #rpath=1 => {Disable use of the rpath linker flag} + rpath=1 => {Disable use of the rpath linker flag} + # soname: https://sqlite.org/src/forumpost/5a3b44f510df8ded soname:=legacy => {SONAME for libsqlite3.so. "none", or not using this flag, sets no @@ -616,7 +618,7 @@ proc sqlite-check-common-system-deps {} { # Check for needed/wanted functions cc-check-functions gmtime_r isnan localtime_r localtime_s \ - malloc_usable_size strchrnul usleep utime pread pread64 pwrite pwrite64 + strchrnul usleep utime pread pread64 pwrite pwrite64 apply {{} { set ldrt "" @@ -772,7 +774,8 @@ proc sqlite-handle-common-feature-flags {} { sqlite-add-feature-flag -DSQLITE_ENABLE_MEMSYS3 } } - scanstatus -DSQLITE_ENABLE_STMT_SCANSTATUS {} + scanstatus -DSQLITE_ENABLE_STMT_SCANSTATUS {} + column-metadata -DSQLITE_ENABLE_COLUMN_METADATA {} }] { if {$boolFlag ni $::autosetup(options)} { # Skip flags which are in the canonical build but not @@ -1969,13 +1972,14 @@ proc sqlite-check-tcl {} { # TCLLIBDIR from here, which will cause the canonical makefile to # use this one rather than to re-calculate it at make-time. set tcllibdir [get-env TCLLIBDIR ""] + set sq3Ver [get-define PACKAGE_VERSION] if {"" eq $tcllibdir} { # Attempt to extract TCLLIBDIR from TCL's $auto_path if {"" ne $with_tclsh && [catch {exec echo "puts stdout \$auto_path" | "$with_tclsh"} result] == 0} { foreach i $result { if {[file isdir $i]} { - set tcllibdir $i/sqlite3 + set tcllibdir $i/sqlite${sq3Ver} break } } @@ -2111,15 +2115,31 @@ proc sqlite-determine-codegen-tcl {} { # sqlite-determine-codegen-tcl. proc sqlite-handle-tcl {} { sqlite-check-tcl - if {"canonical" eq $::sqliteConfig(build-mode)} { - msg-result "TCL for code generation: [sqlite-determine-codegen-tcl]" + if {"canonical" ne $::sqliteConfig(build-mode)} return + msg-result "TCL for code generation: [sqlite-determine-codegen-tcl]" + + # Determine the base name of the Tcl extension's DLL + # + if {[get-define HAVE_TCL]} { + if {[string match *-cygwin [get-define host]]} { + set libname cyg + } else { + set libname lib + } + if {[get-define TCL_MAJOR_VERSION] > 8} { + append libname tcl9 + } + append libname sqlite + } else { + set libname "" } + define TCL_EXT_DLL_BASENAME $libname + # The extension is added in the makefile } ######################################################################## # Handle the --enable/disable-rpath flag. proc sqlite-handle-rpath {} { - proj-check-rpath # autosetup/cc-shared.tcl sets the rpath flag definition in # [get-define SH_LINKRPATH], but it does so on a per-platform basis # rather than as a compiler check. Though we should do a proper @@ -2128,12 +2148,13 @@ proc sqlite-handle-rpath {} { # for which sqlite-env-is-unix-on-windows returns a non-empty # string. -# if {[proj-opt-truthy rpath]} { -# proj-check-rpath -# } else { -# msg-result "Disabling use of rpath." -# define LDFLAGS_RPATH "" -# } + # https://sqlite.org/forum/forumpost/13cac3b56516f849 + if {[proj-opt-truthy rpath]} { + proj-check-rpath + } else { + msg-result "Disabling use of rpath." + define LDFLAGS_RPATH "" + } } ######################################################################## diff --git a/autosetup/teaish/core.tcl b/autosetup/teaish/core.tcl index 381597ec5..a4a6b001f 100644 --- a/autosetup/teaish/core.tcl +++ b/autosetup/teaish/core.tcl @@ -92,6 +92,7 @@ array set teaish__Config [proj-strip-hash-comments { -tm.tcl.in TEAISH_TM_TCL_IN -options {} -pragmas {} + -src {} } # @@ -331,29 +332,33 @@ proc teaish-configure-core {} { -url - -v "" -tm.tcl - -v "" -tm.tcl.in - -v "" + -src - -v "" } { + #proj-assert 0 {Just testing} set isPIFlag [expr {"-" ne $pflag}] if {$isPIFlag} { if {[info exists ::teaish__PkgInfo($pflag)]} { # Was already set - skip it. continue; } - proj-assert {{-} eq $key} + proj-assert {{-} eq $key};# "Unexpected pflag=$pflag key=$key type=$type val=$val" set key $f2d($pflag) } - proj-assert {"" ne $key} - set got [get-define $key "<nope>"] - if {"<nope>" ne $got} { - # Was already set - skip it. - continue + if {"" ne $key} { + if {"<nope>" ne [get-define $key "<nope>"]} { + # Was already set - skip it. + continue + } } switch -exact -- $type { -v {} -e { set val [eval $val] } default { proj-error "Invalid type flag: $type" } } - #puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag got=$got" - define $key $val + #puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag" + if {$key ne ""} { + define $key $val + } if {$isPIFlag} { set ::teaish__PkgInfo($pflag) $val } @@ -522,7 +527,7 @@ proc teaish__configure_phase1 {} { set vputs "puts \[ $vsat \]" #puts "*** vputs = $vputs" scan [exec echo $vputs | $tclsh] %d vvcheck - if {0 == $vvcheck} { + if {![info exists vvcheck] || 0 == $vvcheck} { proj-fatal -up $tclsh "check failed:" $vsat } } @@ -585,7 +590,8 @@ proc teaish__configure_phase1 {} { # if {0x0f & $::teaish__Config(pkginit-policy)} { file delete -force -- [get-define TEAISH_PKGINIT_TCL] - proj-dot-ins-append [get-define TEAISH_PKGINIT_TCL_IN] + proj-dot-ins-append [get-define TEAISH_PKGINIT_TCL_IN] \ + [get-define TEAISH_PKGINIT_TCL] } if {0x0f & $::teaish__Config(tm-policy)} { file delete -force -- [get-define TEAISH_TM_TCL] @@ -595,17 +601,20 @@ proc teaish__configure_phase1 {} { apply {{} { # Queue up any remaining dot-in files set dotIns [list] - foreach d { - TEAISH_TESTER_TCL_IN - TEAISH_TEST_TCL_IN - TEAISH_MAKEFILE_IN + foreach {dIn => dOut} { + TEAISH_TESTER_TCL_IN => TEAISH_TESTER_TCL + TEAISH_TEST_TCL_IN => TEAISH_TEST_TCL + TEAISH_MAKEFILE_IN => TEAISH_MAKEFILE } { - lappend dotIns [get-define $d ""] - } - lappend dotIns $::autosetup(srcdir)/Makefile.in; # must be after TEAISH_MAKEFILE_IN - foreach f $dotIns { - if {"" ne $f} { - proj-dot-ins-append $f + lappend dotIns [get-define $dIn ""] [get-define $dOut ""] + } + lappend dotIns $::autosetup(srcdir)/Makefile.in Makefile; # must be after TEAISH_MAKEFILE_IN. + # Much later: probably because of timestamps for deps purposes :-? + #puts "dotIns=$dotIns" + foreach {i o} $dotIns { + if {"" ne $i && "" ne $o} { + #puts " pre-dot-ins-append: \[$i\] -> \[$o\]" + proj-dot-ins-append $i $o } } }} @@ -640,10 +649,10 @@ proc teaish__configure_phase1 {} { # # NO [define]s after this point! # - proj-dot-ins-process -validate proj-if-opt-truthy teaish-dump-defines { proj-file-write config.defines.txt $tdefs } + proj-dot-ins-process -validate }; # teaish__configure_phase1 @@ -817,7 +826,9 @@ proc teaish__check_tcl {} { if {"" ne $withSh && [catch {exec echo "puts stdout \$auto_path" | "$withSh"} result] == 0} { foreach i $result { - if {[file isdirectory $i]} { + if {![string match //zip* $i] && [file isdirectory $i]} { + # isdirectory actually passes on //zipfs:/..., but those are + # useless for our purposes set tcllibdir $i/$extDirName break } @@ -1066,7 +1077,7 @@ If you are attempting an out-of-tree build, use ]]} { if {[string match *.in $extM]} { define TEAISH_MAKEFILE_IN $extM - define TEAISH_MAKEFILE [file rootname [file tail $extM]] + define TEAISH_MAKEFILE _[file rootname [file tail $extM]] } else { define TEAISH_MAKEFILE_IN "" define TEAISH_MAKEFILE $extM @@ -1134,8 +1145,8 @@ If you are attempting an out-of-tree build, use set flist [list $dirExt/teaish.test.tcl.in $dirExt/teaish.test.tcl] if {[proj-first-file-found ttt $flist]} { if {[string match *.in $ttt]} { - # Generate teaish.test.tcl from $ttt - set xt [file rootname [file tail $ttt]] + # Generate _teaish.test.tcl from $ttt + set xt _[file rootname [file tail $ttt]] file delete -force -- $xt; # ensure no stale copy is used define TEAISH_TEST_TCL $xt define TEAISH_TEST_TCL_IN $ttt @@ -1302,7 +1313,6 @@ proc teaish-ldflags-prepend {args} { # object files (which are typically in the build tree)). # proc teaish-src-add {args} { - set i 0 proj-parse-simple-flags args flags { -dist 0 {expr 1} -dir 0 {expr 1} @@ -1387,7 +1397,7 @@ proc teaish__cleanup_rule {{tgt clean}} { return ${tgt}-_${x}_ } -# @teaish-make-obj objfile srcfile ?...args? +# @teaish-make-obj ?flags? ?...args? # # Uses teaish-make-add to inject makefile rules for $objfile from # $srcfile, which is assumed to be C code which uses libtcl. Unless @@ -1401,43 +1411,45 @@ proc teaish__cleanup_rule {{tgt clean}} { # Any arguments after the 2nd may be flags described below or, if no # -recipe is provided, flags for the compiler call. # +# -obj obj-filename.o +# +# -src src-filename.c +# # -recipe {...} # Uses the trimmed value of {...} as the recipe, prefixing it with # a single hard-tab character. # # -deps {...} -# List of extra files to list as dependencies of $o. Good luck -# escaping non-trivial cases properly. +# List of extra files to list as dependencies of $o. # # -clean # Generate cleanup rules as well. -proc teaish-make-obj {o src args} { - set consume 0 - set clean 0 - set flag "" - array set flags {} - set xargs {} - foreach arg $args { - if {$consume} { - set consume 0 - set flags($flag) $arg - continue - } - switch -exact -- $arg { - -clean {incr clean} - -recipe - - -deps { - set flag $arg - incr consume - } - default { - lappend xargs $arg - } +proc teaish-make-obj {args} { + proj-parse-simple-flags args flags { + -clean 0 {expr 1} + -recipe => {} + -deps => {} + -obj => {} + -src => {} + } + #parray flags + if {"" eq $flags(-obj)} { + set args [lassign $args flags(-obj)] + if {"" eq $flags(-obj)} { + proj-error "Missing -obj flag." } } + foreach f {-deps -src} { + set flags($f) [string trim [string map {\n " "} $flags($f)]] + } + foreach f {-deps -src} { + set flags($f) [string trim $flags($f)] + } + #parray flags + #puts "-- args=$args" teaish-make-add \ - "# [proj-scope 1] -> [proj-scope] $o $src" -nl \ - "$o: $src $::teaish__Config(teaish.tcl)" + "# [proj-scope 1] -> [proj-scope] $flags(-obj) $flags(-src)" -nl \ + "$flags(-obj): $flags(-src) $::teaish__Config(teaish.tcl)" if {[info exists flags(-deps)]} { teaish-make-add " " [join $flags(-deps)] } @@ -1445,12 +1457,12 @@ proc teaish-make-obj {o src args} { if {[info exists flags(-recipe)]} { teaish-make-add [string trim $flags(-recipe)] -nl } else { - teaish-make-add [join [list \$(CC.tcl) -c $src {*}$xargs]] -nl + teaish-make-add [join [list \$(CC.tcl) -c $flags(-src) {*}$args]] -nl } - if {$clean} { + if {$flags(-clean)} { set rule [teaish__cleanup_rule] teaish-make-add \ - "clean: $rule\n$rule:\n\trm -f \"$o\"\n" + "clean: $rule\n$rule:\n\trm -f \"$flags(-obj)\"\n" } } @@ -2078,6 +2090,17 @@ proc teaish-pkginfo-set {args} { set v $x } + -src { + set d $::teaish__Config(extension-dir) + foreach f $v { + lappend ::teaish__Config(dist-files) $f + lappend ::teaish__Config(extension-src) $d/$f + lappend ::teaish__PkgInfo(-src) $f + # ^^^ so that default-value initialization in + # teaish-configure-core recognizes that it's been set. + } + } + -tm.tcl - -tm.tcl.in { if {0x30 & $::teaish__Config(pkgindex-policy)} { @@ -2515,7 +2538,7 @@ proc teaish__install {{dDest ""}} { ] { teaish__verbose 1 msg-result "Copying files to $destDir..." file mkdir $destDir - foreach f [glob -directory $srcDir *] { + foreach f [glob -nocomplain -directory $srcDir *] { if {[string match {*~} $f] || [string match "#*#" [file tail $f]]} { # Editor-generated backups and emacs lock files continue diff --git a/autosetup/teaish/tester.tcl b/autosetup/teaish/tester.tcl index d8b5f7a0e..a25b366e8 100644 --- a/autosetup/teaish/tester.tcl +++ b/autosetup/teaish/tester.tcl @@ -99,7 +99,7 @@ proc test__affert {failMode args} { lassign $args script msg } incr ::test__Counters($what) - if {![uplevel 1 [concat expr [list $script]]]} { + if {![uplevel 1 expr [list $script]]} { if {"" eq $msg} { set msg $script } @@ -137,6 +137,40 @@ proc assert {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. @@ -157,7 +191,7 @@ 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] \ + tailcall test__affert 0 [list "{$x}" eq "{$result}"] \ "\nEXPECTED: <<$result>>\nGOT: <<$x>>" } @@ -169,7 +203,7 @@ proc test-expect {testId script result} { # proc test-catch {cmd args} { if {[catch { - $cmd {*}$args + uplevel 1 $cmd {*}$args } rc xopts]} { puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc" return 1 @@ -177,6 +211,37 @@ proc test-catch {cmd args} { 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 {} } |