1
0
mirror of https://github.com/sqlite/sqlite.git synced 2025-08-05 15:55:57 +03:00

Configure-related fixes and additions, most notably integration of self-tests for proj.tcl's APIs. Teaish make-install fixes based on the discussion in [forum:87e6660191a472c5 | forum thread 87e6660191a472c5].

FossilOrigin-Name: 2e486f8fd011d28fdd7e59ff34f7f04374019932eb160a8c4de56a5ce01e5782
This commit is contained in:
stephan
2025-05-30 16:08:31 +00:00
parent 7ac10ec8b5
commit f42ceb9075
8 changed files with 593 additions and 213 deletions

View File

@@ -167,6 +167,11 @@ tx.LDFLAGS =
# #
tx.dist.files = @TEAISH_DIST_FILES@ tx.dist.files = @TEAISH_DIST_FILES@
#
# The base name for a distribution tar/zip file.
#
tx.dist.basename = $(tx.name.dist)-$(tx.version)
# List of deps which may trigger an auto-reconfigure. # List of deps which may trigger an auto-reconfigure.
# #
teaish__autogen.deps = \ teaish__autogen.deps = \
@@ -199,9 +204,14 @@ $(teaish.makefile): $(teaish__auto.def) $(teaish.makefile.in) \
@AUTODEPS@ @AUTODEPS@
@if TEAISH_TESTER_TCL_IN @if TEAISH_TESTER_TCL_IN
@TEAISH_TESTER_TCL_IN@: @TEAISH_TESTER_TCL_IN@: $(teaish__autogen.deps)
config.log: @TEAISH_TESTER_TCL_IN@
@TEAISH_TESTER_TCL@: @TEAISH_TESTER_TCL_IN@ @TEAISH_TESTER_TCL@: @TEAISH_TESTER_TCL_IN@
config.log: @TEAISH_TESTER_TCL@ @endif
@if TEAISH_TEST_TCL_IN
@TEAISH_TEST_TCL_IN@: $(teaish__autogen.deps)
config.log: @TEAISH_TEST_TCL_IN@
@TEAISH_TEST_TCL@: @TEAISH_TEST_TCL_IN@
@endif @endif
# #
@@ -217,7 +227,7 @@ CC.tcl = \
# #
CC.dll = \ CC.dll = \
$(CC.tcl) $(tx.src) $(LDFLAGS.shlib) \ $(CC.tcl) $(tx.src) $(LDFLAGS.shlib) \
$(LDFLAGS.configure) $(LDFLAGS) $(tx.LDFLAGS) $(TCL_STUB_LIB_SPEC) $(tx.LDFLAGS) $(LDFLAGS.configure) $(LDFLAGS) $(TCL_STUB_LIB_SPEC)
@if TEAISH_ENABLE_DLL @if TEAISH_ENABLE_DLL
# #
@@ -248,16 +258,25 @@ test-extension: # this name is reserved for use by teaish.make[.in]
test-prepre: $(tx.dll) test-prepre: $(tx.dll)
@endif @endif
@if TEAISH_TESTER_TCL @if TEAISH_TESTER_TCL
test-core.args = @TEAISH_TESTER_TCL@ teaish.tester.tcl = @TEAISH_TESTER_TCL@
test-core.args = $(teaish.tester.tcl)
@if TEAISH_ENABLE_DLL @if TEAISH_ENABLE_DLL
test-core.args += '$(tx.dll)' '$(tx.loadPrefix)' test-core.args += '$(tx.dll)' '$(tx.loadPrefix)'
@else @else
test-core.args += '' '' test-core.args += '' ''
@endif @endif
test-core.args += @TEAISH_TESTUTIL_TCL@ test-core.args += @TEAISH_TESTUTIL_TCL@
# Clients may pass additional args via test.args=...
# and ::argv will be rewritten before the test script loads, to
# remove $(test-core.args)
test.args ?=
test-core: test-pre test-core: test-pre
$(TCLSH) $(test-core.args) $(TCLSH) $(test-core.args) $(test.args)
test-prepre: @TEAISH_TESTER_TCL@ test-gdb: $(teaish.tester.tcl)
gdb --args $(TCLSH) $(test-core.args) $(test.args)
test-vg.flags ?= --leak-check=full -v --show-reachable=yes --track-origins=yes
test-vg: $(teaish.tester.tcl)
valgrind $(test-vg.flags) $(TCLSH) $(test-core.args) $(test.args)
@else # !TEAISH_TESTER_TCL @else # !TEAISH_TESTER_TCL
test-prepre: test-prepre:
@endif # TEAISH_TESTER_TCL @endif # TEAISH_TESTER_TCL
@@ -288,7 +307,7 @@ distclean-core: distclean-pre
@endif @endif
@endif @endif
@if TEAISH_TESTER_TCL_IN @if TEAISH_TESTER_TCL_IN
rm -f @TEAISH_TESTER_TCL@ rm -f $(teaish.tester.tcl)
@endif @endif
@if TEAISH_PKGINDEX_TCL_IN @if TEAISH_PKGINDEX_TCL_IN
rm -f @TEAISH_PKGINDEX_TCL@ rm -f @TEAISH_PKGINDEX_TCL@
@@ -355,10 +374,15 @@ install-core: install-pre
@endif @endif
install-test: install-core install-test: install-core
@echo "Post-install test of [package require $(tx.name.pkg) $(tx.version)]..."; \ @echo "Post-install test of [package require $(tx.name.pkg) $(tx.version)]..."; \
set xtra=""; \
if [ x != "x$(DESTDIR)" ]; then \
xtra='set ::auto_path [linsert $$::auto_path 0 [file normalize $(DESTDIR)$(TCLLIBDIR)/..]];'; \
fi; \
if echo \ if echo \
'set c 0; ' \ 'set c 0; ' $$xtra \
'@TEAISH_POSTINST_PREREQUIRE@' \ '@TEAISH_POSTINST_PREREQUIRE@' \
'if {[catch {package require $(tx.name.pkg) $(tx.version)}]} {incr c};' \ 'if {[catch {package require $(tx.name.pkg) $(tx.version)} xc]} {incr c};' \
'if {$$c && "" ne $$xc} {puts $$xc; puts "auto_path=$$::auto_path"};' \
'exit $$c' \ 'exit $$c' \
| $(TCLSH) ; then \ | $(TCLSH) ; then \
echo "passed"; \ echo "passed"; \
@@ -406,7 +430,7 @@ config.log: $(teaish.makefile.in)
# recognized when running in --teaish-install mode, causing # recognized when running in --teaish-install mode, causing
# the sub-configure to fail. # the sub-configure to fail.
dist.flags = --with-tclsh=$(TCLSH) dist.flags = --with-tclsh=$(TCLSH)
dist.reconfig = $(teaish.dir)/configure $(dist.flags) dist.reconfig = $(teaish.dir)/configure $(tx.dist.reconfig-flags) $(dist.flags)
# Temp dir for dist.zip. Must be different than dist.tgz or else # Temp dir for dist.zip. Must be different than dist.tgz or else
# parallel builds may hose the dist. # parallel builds may hose the dist.
@@ -414,24 +438,23 @@ teaish__dist.tmp.zip = teaish__dist_zip
# #
# Make a distribution zip file... # Make a distribution zip file...
# #
dist.basename = $(tx.name.dist)-$(tx.version) dist.zip = $(tx.dist.basename).zip
dist.zip = $(dist.basename).zip
.PHONY: dist.zip dist.zip-core dist.zip-post .PHONY: dist.zip dist.zip-core dist.zip-post
#dist.zip-pre: #dist.zip-pre:
# We apparently can't add a pre-hook here, else "make dist" rebuilds # We apparently can't add a pre-hook here, else "make dist" rebuilds
# the archive each time it's run. # the archive each time it's run.
$(dist.zip): $(tx.dist.files) $(dist.zip): $(tx.dist.files)
@rm -fr $(teaish__dist.tmp.zip) @rm -fr $(teaish__dist.tmp.zip)
@mkdir -p $(teaish__dist.tmp.zip)/$(dist.basename) @mkdir -p $(teaish__dist.tmp.zip)/$(tx.dist.basename)
@tar cf $(teaish__dist.tmp.zip)/tmp.tar $(tx.dist.files) @tar cf $(teaish__dist.tmp.zip)/tmp.tar $(tx.dist.files)
@tar xf $(teaish__dist.tmp.zip)/tmp.tar -C $(teaish__dist.tmp.zip)/$(dist.basename) @tar xf $(teaish__dist.tmp.zip)/tmp.tar -C $(teaish__dist.tmp.zip)/$(tx.dist.basename)
@if TEAISH_DIST_FULL @if TEAISH_DIST_FULL
@$(dist.reconfig) \ @$(dist.reconfig) \
--teaish-install=$(teaish__dist.tmp.zip)/$(dist.basename) \ --teaish-install=$(teaish__dist.tmp.zip)/$(tx.dist.basename) \
--t-e-d=$(teaish__dist.tmp.zip)/$(dist.basename) >/dev/null --t-e-d=$(teaish__dist.tmp.zip)/$(tx.dist.basename) >/dev/null
@endif @endif
@rm -f $(dist.basename)/tmp.tar $(dist.zip) @rm -f $(tx.dist.basename)/tmp.tar $(dist.zip)
@cd $(teaish__dist.tmp.zip) && zip -q -r ../$(dist.zip) $(dist.basename) @cd $(teaish__dist.tmp.zip) && zip -q -r ../$(dist.zip) $(tx.dist.basename)
@rm -fr $(teaish__dist.tmp.zip) @rm -fr $(teaish__dist.tmp.zip)
@ls -la $(dist.zip) @ls -la $(dist.zip)
dist.zip-core: $(dist.zip) dist.zip-core: $(dist.zip)
@@ -447,23 +470,23 @@ undist: undist-zip
# Make a distribution tarball... # Make a distribution tarball...
# #
teaish__dist.tmp.tgz = teaish__dist_tgz teaish__dist.tmp.tgz = teaish__dist_tgz
dist.tgz = $(dist.basename).tar.gz dist.tgz = $(tx.dist.basename).tar.gz
.PHONY: dist.tgz dist.tgz-core dist.tgz-post .PHONY: dist.tgz dist.tgz-core dist.tgz-post
# dist.tgz-pre: # dist.tgz-pre:
# see notes in dist.zip # see notes in dist.zip
$(dist.tgz): $(tx.dist.files) $(dist.tgz): $(tx.dist.files)
@rm -fr $(teaish__dist.tmp.tgz) @rm -fr $(teaish__dist.tmp.tgz)
@mkdir -p $(teaish__dist.tmp.tgz)/$(dist.basename) @mkdir -p $(teaish__dist.tmp.tgz)/$(tx.dist.basename)
@tar cf $(teaish__dist.tmp.tgz)/tmp.tar $(tx.dist.files) @tar cf $(teaish__dist.tmp.tgz)/tmp.tar $(tx.dist.files)
@tar xf $(teaish__dist.tmp.tgz)/tmp.tar -C $(teaish__dist.tmp.tgz)/$(dist.basename) @tar xf $(teaish__dist.tmp.tgz)/tmp.tar -C $(teaish__dist.tmp.tgz)/$(tx.dist.basename)
@if TEAISH_DIST_FULL @if TEAISH_DIST_FULL
@rm -f $(teaish__dist.tmp.tgz)/$(dist.basename)/pkgIndex.tcl.in; # kludge @rm -f $(teaish__dist.tmp.tgz)/$(tx.dist.basename)/pkgIndex.tcl.in; # kludge
@$(dist.reconfig) \ @$(dist.reconfig) \
--teaish-install=$(teaish__dist.tmp.tgz)/$(dist.basename) \ --teaish-install=$(teaish__dist.tmp.tgz)/$(tx.dist.basename) \
--t-e-d=$(teaish__dist.tmp.zip)/$(dist.basename) >/dev/null --t-e-d=$(teaish__dist.tmp.zip)/$(tx.dist.basename) >/dev/null
@endif @endif
@rm -f $(dist.basename)/tmp.tar $(dist.tgz) @rm -f $(tx.dist.basename)/tmp.tar $(dist.tgz)
@cd $(teaish__dist.tmp.tgz) && tar czf ../$(dist.tgz) $(dist.basename) @cd $(teaish__dist.tmp.tgz) && tar czf ../$(dist.tgz) $(tx.dist.basename)
@rm -fr $(teaish__dist.tmp.tgz) @rm -fr $(teaish__dist.tmp.tgz)
@ls -la $(dist.tgz) @ls -la $(dist.tgz)
dist.tgz-core: $(dist.tgz) dist.tgz-core: $(dist.tgz)

View File

@@ -21,7 +21,8 @@ if {[llength [lindex $::argv 0]] > 0} {
# ----^^^^^^^ needed on Haiku when argv 0 is just a filename, else # ----^^^^^^^ needed on Haiku when argv 0 is just a filename, else
# load cannot find the file. # load cannot find the file.
} }
source -encoding utf-8 [lindex $::argv 2]; # teaish/tester.tcl set ::argv [lassign $argv - -]
source -encoding utf-8 [lindex $::argv 0]; # teaish/tester.tcl
@if TEAISH_PKGINIT_TCL @if TEAISH_PKGINIT_TCL
apply {{file} { apply {{file} {
set dir [file dirname $::argv0] set dir [file dirname $::argv0]

View File

@@ -67,6 +67,7 @@ apply {{dir} {
-vsatisfies 8.6- -vsatisfies 8.6-
-libDir sqlite$version -libDir sqlite$version
-pragmas $pragmas -pragmas $pragmas
-src generic/tclsqlite3.c
} }
}} [teaish-get -dir] }} [teaish-get -dir]
@@ -119,8 +120,6 @@ proc teaish-options {} {
proc teaish-configure {} { proc teaish-configure {} {
use teaish/feature use teaish/feature
teaish-src-add -dist -dir generic/tclsqlite3.c
if {[proj-opt-was-provided override-sqlite-version]} { if {[proj-opt-was-provided override-sqlite-version]} {
teaish-pkginfo-set -version [opt-val override-sqlite-version] teaish-pkginfo-set -version [opt-val override-sqlite-version]
proj-warn "overriding sqlite version number:" [teaish-pkginfo-get -version] proj-warn "overriding sqlite version number:" [teaish-pkginfo-get -version]

View File

@@ -60,10 +60,11 @@
# $proj__Config is an internal-use-only array for storing whatever generic # $proj__Config is an internal-use-only array for storing whatever generic
# internal stuff we need stored. # internal stuff we need stored.
# #
array set ::proj__Config { array set ::proj__Config [subst {
self-tests 1 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 # 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 # See: proj-dot-ins-append and proj-dot-ins-process
# #
set ::proj__Config(dot-in-files) [list] set ::proj__Config(dot-in-files) [list]
set ::proj__Config(isatty) [isatty? stdout]
# #
# @proj-warn msg # @proj-warn msg
@@ -85,28 +85,29 @@ set ::proj__Config(isatty) [isatty? stdout]
# #
proc proj-warn {args} { proc proj-warn {args} {
show-notices 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 # Internal impl of [proj-fatal] and [proj-error]. It must be called
# using tailcall. # using tailcall.
proc proj__faterr {failMode argv} { #
proc proj__faterr {failMode args} {
show-notices show-notices
set lvl 1 set lvl 1
while {"-up" eq [lindex $argv 0]} { while {"-up" eq [lindex $args 0]} {
set argv [lassign $argv -] set args [lassign $args -]
incr lvl incr lvl
} }
if {$failMode} { if {$failMode} {
puts stderr [join [list "FATAL: \[[proj-scope $lvl]]: " {*}$argv]] puts stderr [join [list "FATAL:" \[ [proj-scope $lvl] \]: {*}$args]]
exit 1 exit 1
} else { } else {
error [join [list "\[[proj-scope $lvl]]:" {*}$argv]] error [join [list in \[ [proj-scope $lvl] \]: {*}$args]]
} }
} }
# #
# @proj-fatal ?-up...? msg... # @proj-fatal ?-up...? msg...
# #
@@ -118,7 +119,7 @@ proc proj__faterr {failMode argv} {
# additional level. # additional level.
# #
proc proj-fatal {args} { 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]. # Works like proj-fatal but uses [error] intead of [exit].
# #
proc proj-error {args} { 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? # @proj-assert script ?message?
# #
@@ -147,7 +147,7 @@ proc proj-assert {script {msg ""}} {
if {"" eq $msg} { if {"" eq $msg} {
set msg $script set msg $script
} }
proj-fatal "Assertion failed in \[[proj-scope 1]\]: $msg" tailcall proj__faterr 1 "Assertion failed:" $msg
} }
} }
@@ -1665,7 +1665,7 @@ proc proj-dot-ins-append {fileIn args} {
proj-fatal "Too many arguments: $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 lappend ::proj__Config(dot-in-files) $fileIn
} }
@@ -1703,17 +1703,18 @@ proc proj-dot-ins-list {} {
# makes proj-dot-ins-append available for re-use. # makes proj-dot-ins-append available for re-use.
# #
proc proj-dot-ins-process {args} { proc proj-dot-ins-process {args} {
proj-parse-simple-flags args flags { proj-parse-flags args flags {
-touch "" {return "-touch"} -touch "" {return "-touch"}
-clear 0 {expr 1} -clear 0 {expr 1}
-validate 0 {expr 1} -validate 0 {expr 1}
} }
#puts "args=$args"; parray flags
if {[llength $args] > 0} { if {[llength $args] > 0} {
error "Invalid argument to [proj-scope]: $args" error "Invalid argument to [proj-scope]: $args"
} }
foreach f $::proj__Config(dot-in-files) { foreach f $::proj__Config(dot-in-files) {
proj-assert {3==[llength $f]} \ 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 lassign $f fIn fOut fScript
#puts "DOING $fIn ==> $fOut" #puts "DOING $fIn ==> $fOut"
proj-make-from-dot-in {*}$flags(-touch) $fIn $fOut proj-make-from-dot-in {*}$flags(-touch) $fIn $fOut
@@ -1753,7 +1754,7 @@ proc proj-validate-no-unresolved-ats {args} {
set isMake [string match {*[Mm]ake*} $f] set isMake [string match {*[Mm]ake*} $f]
foreach line [proj-file-content-list $f] { foreach line [proj-file-content-list $f] {
if {!$isMake || ![string match "#*" [string trimleft $line]]} { 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" error "Unresolved reference to $match at line $lnno of $f"
} }
} }
@@ -1893,7 +1894,7 @@ proc proj-define-amend {args} {
# #
proc proj-define-to-cflag {args} { proc proj-define-to-cflag {args} {
set rv {} set rv {}
proj-parse-simple-flags args flags { proj-parse-flags args flags {
-list 0 {expr 1} -list 0 {expr 1}
-quote 0 {expr 1} -quote 0 {expr 1}
-zero-undef 0 {expr 1} -zero-undef 0 {expr 1}
@@ -2001,7 +2002,7 @@ proc proj-cache-key {arg {addLevel 0}} {
# See proj-cache-key for -key's and -level's semantics, noting that # See proj-cache-key for -key's and -level's semantics, noting that
# this function adds one to -level for purposes of that call. # this function adds one to -level for purposes of that call.
proc proj-cache-set {args} { proc proj-cache-set {args} {
proj-parse-simple-flags args flags { proj-parse-flags args flags {
-key => 0 -key => 0
-level => 0 -level => 0
} }
@@ -2037,7 +2038,7 @@ proc proj-cache-remove {{key 0} {addLevel 0}} {
# See proj-cache-key for $key's and $addLevel's semantics, noting that # See proj-cache-key for $key's and $addLevel's semantics, noting that
# this function adds one to $addLevel for purposes of that call. # this function adds one to $addLevel for purposes of that call.
proc proj-cache-check {args} { proc proj-cache-check {args} {
proj-parse-simple-flags args flags { proj-parse-flags args flags {
-key => 0 -key => 0
-level => 0 -level => 0
} }
@@ -2070,147 +2071,321 @@ proc proj-coalesce {args} {
} }
# #
# @proj-parse-simple-flags ... # @proj-parse-flags argvListName targetArrayName {prototype}
# #
# A helper to parse flags from proc argument lists. # A helper to parse flags from proc argument lists.
# #
# Expects a list of arguments to parse, an array name to store any # The first argument is the name of a var holding the args to
# -flag values to, and a prototype object which declares the flags. # 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 # -flag defaultValue ?-literal|-call|-apply?
# -----^--^ (with spaces there!) # script|number|incr|proc-name|{apply $aLambda}
# #
# Repeated for each flag. # -flag* ...as above...
# #
# The first form represents a basic flag with no associated # -flag => defaultValue ?-call proc-name-and-args|-apply lambdaExpr?
# following argument. The second form extracts its value
# from the following argument in $argvName.
# #
# The first argument to this function is the name of a var holding the # -flag* => ...as above...
# args to parse. It will be overwritten, possibly with a smaller list.
# #
# The second argument the name of an array variable to create in the # :PRAGMA
# caller's scope. (Pneumonic: => points to the next argument.)
# #
# For the first form of flag, $script is run in the caller's scope if # The first two forms represents a basic flag with no associated
# $argv contains -flag, and the result of that script is the new value # following argument. The third and fourth forms, called arg-consuming
# for $tgtArrayName(-flag). This function intercepts [return $val] # flags, extract the value from the following argument in $argvName
# from $script. Any empty script will result in the flag having "" # (pneumonic: => points to the next argument.). The :PRAGMA form
# assigned to it. # offers a way to configure certain aspects of this call.
# #
# The args list is only inspected until the first argument which is # If $argv contains any given flag from $prototype, its default value
# not described by $prototype. i.e. the first "non-flag" (not counting # is overridden depending on several factors:
# values consumed for flags defined like --flag=>default). #
# - 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.
#
# 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:
#
# - 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.
#
# - 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 # If a "--" flag is encountered, no more arguments are inspected as
# flags. If "--" is the first non-flag argument, the "--" flag is # flags unless the :all-flags pragma (see below) is in effect. The
# removed from the results but all remaining arguments are passed # first instance of "--" is removed from the target result list but
# through. If "--" appears after the first non-flag, it is retained. # all remaining instances of "--" are are passed through.
# #
# This function assumes that each flag is unique, and using a flag # Any argvName entries not described in $prototype are considered to
# more than once behaves in a last-one-wins fashion. # be "non-flags" for purposes of this function, even if they
# ostensibly look like flags.
# #
# Any argvName entries not described in $prototype are not treated as # Returns the number of flags it processed in $argvName, not counting
# flags. # "--".
#
# Returns the number of flags it processed in $argvName.
# #
# Example: # Example:
# #
# set args [list -foo -bar {blah} 8 9 10 -theEnd] ## set args [list -foo -bar {blah} -z 8 9 10 -theEnd]
# proj-parse-simple-flags args flags { ## proj-parse-flags args flags {
# -foo 0 {expr 1} ## -foo 0 {expr 1}
# -bar => 0 ## -bar => 0
# -no-baz 2 {return 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}. # and $args would be {8 9 10 -theEnd}.
# #
# Potential TODOs: consider using lappend instead of set so that any # Pragmas:
# 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
# #
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 $argvName argv
upvar $tgtArrayName tgt upvar $tgtArrayName outFlags
array set dflt {} array set flags {}; # staging area
array set scripts {} array set scripts {}; # map of -flag=>script
array set consuming {} array set consuming {}; # map of -flag=>1 for arg-consuming flags
array set multi {}; # map of -flag=>1 for multi-time flags
array set seen {}; # map of -flag=>number of times seen
array set call {}; # map of -flag=>1 for -call entries
set incrSkip 1; # 1 if we stop at the first non-flag, else 0
# Parse $prototype for flag definitions...
set n [llength $prototype] 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 consuming($k)]}
set scripts($k) [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 call($k) "apply $fv"
}
-call {
# arg is either a proc name or {apply $aLambda}
set fv [lindex $prototype [incr i]]
lappend call($k) $fv
}
default {
proj-assert {![info exists consuming($k)]}
set scripts($k) $fv
}
}
if {$i >= $n} {
proj-error -up "[proj-scope]: Missing argument for $k flag"
}
}
for {set i 0} {$i < $n} {incr i} { for {set i 0} {$i < $n} {incr i} {
set k [lindex $prototype $i] set k [lindex $prototype $i]
#puts "**** #$i of $n k=$k" #puts "**** #$i of $n k=$k"
# Check for :PRAGMA...
switch -exact -- $k {
:all-flags {
set incrSkip 0
continue
}
}
proj-assert {[string match -* $k]} \ proj-assert {[string match -* $k]} \
"Invalid flag value: $k" "Invalid argument: $k"
set v ""
set s "" if {[string match {*\*} $k]} {
# Re-map -foo* to -foo and flag -foo as a repeatable flag
set k [string map {* ""} $k]
incr multi($k)
}
if {[info exists flags($k)]} {
proj-error -up "[proj-scope]: Duplicated prototype for flag $k"
}
switch -exact -- [lindex $prototype [expr {$i + 1}]] { switch -exact -- [lindex $prototype [expr {$i + 1}]] {
=> { => {
# -flag => DFLT ?-subflag arg?
incr i 2 incr i 2
if {$i >= $n} { if {$i >= $n} {
proj-error "Missing argument for $k => flag" proj-error -up "[proj-scope]: Missing argument for $k => flag"
}
incr consuming($k)
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 { default {
set v [lindex $prototype [incr i]] # -flag VALUE ?flag? SCRIPT
set s [lindex $prototype [incr i]] set vi [lindex $prototype [incr i]]
set scripts($k) $s set fv [lindex $prototype [incr i]]
eval $checkProtoFlag
} }
} }
#puts "**** #$i of $n k=$k v=$v s=$s" #puts "**** #$i of $n k=$k vi=$vi"
set dflt($k) $v set flags($k) $vi
} }
# Now look for those flags in the source list #puts "-- flags"; parray flags
array set tgt [array get dflt] #puts "-- scripts"; parray scripts
unset dflt #puts "-- calls"; parray call
set rc 0 set rc 0
set rv {} set rv {}
set skipMode 0 set skipMode 0
set n [llength $argv] set n [llength $argv]
# Now look for those flags in $argv...
for {set i 0} {$i < $n} {incr i} { for {set i 0} {$i < $n} {incr i} {
set arg [lindex $argv $i] set arg [lindex $argv $i]
#puts "-- [proj-scope] arg=$arg"
if {$skipMode} { if {$skipMode} {
lappend rv $arg lappend rv $arg
} elseif {"--" eq $arg} { } elseif {"--" eq $arg} {
incr skipMode # "--" is the conventional way to end processing of args
} elseif {[info exists tgt($arg)]} { if {[incr seen(--)] > 1} {
if {[info exists consuming($arg)]} { # Elide only the first one
if {$i + 1 >= $n} { lappend rv $arg
proj-assert 0 {Cannot happen - bounds already checked}
} }
set tgt($arg) [lindex $argv [incr i]] incr skipMode $incrSkip
} elseif {"" eq $scripts($arg)} { } elseif {[info exists flags($arg)]} {
set tgt($arg) "" # A known flag...
} else { set isMulti [info exists multi($arg)]
#puts "**** running scripts($arg) $scripts($arg)" incr seen($arg)
set code [catch {uplevel 1 $scripts($arg)} xrc xopt] if {1 < $seen($arg) && !$isMulti} {
#puts "**** tgt($arg)=$scripts($arg) code=$code rc=$rc" proj-error -up [proj-scope] "$arg flag was used multiple times"
if {$code in {0 2}} {
set tgt($arg) $xrc
} else {
return {*}$xopt $xrc
} }
set vMode 0; # 0=as-is, 1=eval, 2=call
set isConsuming [info exists consuming($arg)]
if {$isConsuming} {
incr i
if {$i >= $n} {
proj-error -up [proj-scope] "is missing argument for $arg flag"
}
set vv [lindex $argv $i]
} elseif {[info exists scripts($arg)]} {
set vMode 1
set vv $scripts($arg)
} else {
set vv $flags($arg)
}
if {[info exists call($arg)]} {
set vMode 2
set vv [concat {*}$call($arg) $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 == $seen($arg)} {
# On the first hit, overwrite the default with a new list.
set flags($arg) [list $vv]
} else {
# On subsequent hits, append to the list.
lappend flags($arg) $vv
}
} else {
set flags($arg) $vv
} }
incr rc incr rc
} else { } else {
incr skipMode # Non-flag
incr skipMode $incrSkip
lappend rv $arg lappend rv $arg
} }
} }
set argv $rv set argv $rv
array set outFlags [array get flags]
#puts "-- rv=$rv argv=$argv flags="; parray flags
return $rc 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)} { 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 {{} { apply {{} {
#proj-warn "Test code for proj-cache" #proj-warn "Test code for proj-cache"
proj-assert {![proj-cache-check -key here check]} proj-assert {![proj-cache-check -key here check]}
@@ -2233,4 +2408,100 @@ if {$::proj__Config(self-tests)} {
proj-assert {"" eq [proj-cache-remove]} proj-assert {"" eq [proj-cache-remove]}
proj-assert {"" eq $check} 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

View File

@@ -92,6 +92,7 @@ array set teaish__Config [proj-strip-hash-comments {
-tm.tcl.in TEAISH_TM_TCL_IN -tm.tcl.in TEAISH_TM_TCL_IN
-options {} -options {}
-pragmas {} -pragmas {}
-src {}
} }
# #
@@ -331,29 +332,33 @@ proc teaish-configure-core {} {
-url - -v "" -url - -v ""
-tm.tcl - -v "" -tm.tcl - -v ""
-tm.tcl.in - -v "" -tm.tcl.in - -v ""
-src - -v ""
} { } {
#proj-assert 0 {Just testing}
set isPIFlag [expr {"-" ne $pflag}] set isPIFlag [expr {"-" ne $pflag}]
if {$isPIFlag} { if {$isPIFlag} {
if {[info exists ::teaish__PkgInfo($pflag)]} { if {[info exists ::teaish__PkgInfo($pflag)]} {
# Was already set - skip it. # Was already set - skip it.
continue; continue;
} }
proj-assert {{-} eq $key} proj-assert {{-} eq $key};# "Unexpected pflag=$pflag key=$key type=$type val=$val"
set key $f2d($pflag) set key $f2d($pflag)
} }
proj-assert {"" ne $key} if {"" ne $key} {
set got [get-define $key "<nope>"] if {"<nope>" ne [get-define $key "<nope>"]} {
if {"<nope>" ne $got} {
# Was already set - skip it. # Was already set - skip it.
continue continue
} }
}
switch -exact -- $type { switch -exact -- $type {
-v {} -v {}
-e { set val [eval $val] } -e { set val [eval $val] }
default { proj-error "Invalid type flag: $type" } default { proj-error "Invalid type flag: $type" }
} }
#puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag got=$got" #puts "***** defining default $pflag $key {$val} isPIFlag=$isPIFlag"
if {$key ne ""} {
define $key $val define $key $val
}
if {$isPIFlag} { if {$isPIFlag} {
set ::teaish__PkgInfo($pflag) $val set ::teaish__PkgInfo($pflag) $val
} }
@@ -541,10 +546,10 @@ proc teaish__configure_phase1 {} {
define TEAISH_VSATISFIES_CODE [join $code "\n"] define TEAISH_VSATISFIES_CODE [join $code "\n"]
}}; # vsatisfies }}; # vsatisfies
if {[proj-looks-like-windows] || [proj-looks-like-mac]} { if {[proj-looks-like-windows]} {
# Without this, linking of an extension will not work on Cygwin or # Without this, linking of an extension will not work on Cygwin or
# Msys2. # Msys2.
msg-result "Using USE_TCL_STUBS for this environment" msg-result "Using USE_TCL_STUBS for Unix(ish)-on-Windows environment"
teaish-cflags-add -DUSE_TCL_STUBS=1 teaish-cflags-add -DUSE_TCL_STUBS=1
} }
@@ -585,7 +590,8 @@ proc teaish__configure_phase1 {} {
# #
if {0x0f & $::teaish__Config(pkginit-policy)} { if {0x0f & $::teaish__Config(pkginit-policy)} {
file delete -force -- [get-define TEAISH_PKGINIT_TCL] 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)} { if {0x0f & $::teaish__Config(tm-policy)} {
file delete -force -- [get-define TEAISH_TM_TCL] file delete -force -- [get-define TEAISH_TM_TCL]
@@ -595,17 +601,20 @@ proc teaish__configure_phase1 {} {
apply {{} { apply {{} {
# Queue up any remaining dot-in files # Queue up any remaining dot-in files
set dotIns [list] set dotIns [list]
foreach d { foreach {dIn => dOut} {
TEAISH_TESTER_TCL_IN TEAISH_TESTER_TCL_IN => TEAISH_TESTER_TCL
TEAISH_TEST_TCL_IN TEAISH_TEST_TCL_IN => TEAISH_TEST_TCL
TEAISH_MAKEFILE_IN TEAISH_MAKEFILE_IN => TEAISH_MAKEFILE
} { } {
lappend dotIns [get-define $d ""] lappend dotIns [get-define $dIn ""] [get-define $dOut ""]
} }
lappend dotIns $::autosetup(srcdir)/Makefile.in; # must be after TEAISH_MAKEFILE_IN lappend dotIns $::autosetup(srcdir)/Makefile.in Makefile; # must be after TEAISH_MAKEFILE_IN.
foreach f $dotIns { # Much later: probably because of timestamps for deps purposes :-?
if {"" ne $f} { #puts "dotIns=$dotIns"
proj-dot-ins-append $f 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! # NO [define]s after this point!
# #
proj-dot-ins-process -validate
proj-if-opt-truthy teaish-dump-defines { proj-if-opt-truthy teaish-dump-defines {
proj-file-write config.defines.txt $tdefs proj-file-write config.defines.txt $tdefs
} }
proj-dot-ins-process -validate
}; # teaish__configure_phase1 }; # teaish__configure_phase1
@@ -1068,7 +1077,7 @@ If you are attempting an out-of-tree build, use
]]} { ]]} {
if {[string match *.in $extM]} { if {[string match *.in $extM]} {
define TEAISH_MAKEFILE_IN $extM define TEAISH_MAKEFILE_IN $extM
define TEAISH_MAKEFILE [file rootname [file tail $extM]] define TEAISH_MAKEFILE _[file rootname [file tail $extM]]
} else { } else {
define TEAISH_MAKEFILE_IN "" define TEAISH_MAKEFILE_IN ""
define TEAISH_MAKEFILE $extM define TEAISH_MAKEFILE $extM
@@ -1136,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] set flist [list $dirExt/teaish.test.tcl.in $dirExt/teaish.test.tcl]
if {[proj-first-file-found ttt $flist]} { if {[proj-first-file-found ttt $flist]} {
if {[string match *.in $ttt]} { if {[string match *.in $ttt]} {
# Generate teaish.test.tcl from $ttt # Generate _teaish.test.tcl from $ttt
set xt [file rootname [file tail $ttt]] set xt _[file rootname [file tail $ttt]]
file delete -force -- $xt; # ensure no stale copy is used file delete -force -- $xt; # ensure no stale copy is used
define TEAISH_TEST_TCL $xt define TEAISH_TEST_TCL $xt
define TEAISH_TEST_TCL_IN $ttt define TEAISH_TEST_TCL_IN $ttt
@@ -1304,7 +1313,6 @@ proc teaish-ldflags-prepend {args} {
# object files (which are typically in the build tree)). # object files (which are typically in the build tree)).
# #
proc teaish-src-add {args} { proc teaish-src-add {args} {
set i 0
proj-parse-simple-flags args flags { proj-parse-simple-flags args flags {
-dist 0 {expr 1} -dist 0 {expr 1}
-dir 0 {expr 1} -dir 0 {expr 1}
@@ -1389,7 +1397,7 @@ proc teaish__cleanup_rule {{tgt clean}} {
return ${tgt}-_${x}_ 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 # Uses teaish-make-add to inject makefile rules for $objfile from
# $srcfile, which is assumed to be C code which uses libtcl. Unless # $srcfile, which is assumed to be C code which uses libtcl. Unless
@@ -1403,43 +1411,45 @@ proc teaish__cleanup_rule {{tgt clean}} {
# Any arguments after the 2nd may be flags described below or, if no # Any arguments after the 2nd may be flags described below or, if no
# -recipe is provided, flags for the compiler call. # -recipe is provided, flags for the compiler call.
# #
# -obj obj-filename.o
#
# -src src-filename.c
#
# -recipe {...} # -recipe {...}
# Uses the trimmed value of {...} as the recipe, prefixing it with # Uses the trimmed value of {...} as the recipe, prefixing it with
# a single hard-tab character. # a single hard-tab character.
# #
# -deps {...} # -deps {...}
# List of extra files to list as dependencies of $o. Good luck # List of extra files to list as dependencies of $o.
# escaping non-trivial cases properly.
# #
# -clean # -clean
# Generate cleanup rules as well. # Generate cleanup rules as well.
proc teaish-make-obj {o src args} { proc teaish-make-obj {args} {
set consume 0 proj-parse-simple-flags args flags {
set clean 0 -clean 0 {expr 1}
set flag "" -recipe => {}
array set flags {} -deps => {}
set xargs {} -obj => {}
foreach arg $args { -src => {}
if {$consume} {
set consume 0
set flags($flag) $arg
continue
} }
switch -exact -- $arg { #parray flags
-clean {incr clean} if {"" eq $flags(-obj)} {
-recipe - set args [lassign $args flags(-obj)]
-deps { if {"" eq $flags(-obj)} {
set flag $arg proj-error "Missing -obj flag."
incr consume
}
default {
lappend xargs $arg
} }
} }
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 \ teaish-make-add \
"# [proj-scope 1] -> [proj-scope] $o $src" -nl \ "# [proj-scope 1] -> [proj-scope] $flags(-obj) $flags(-src)" -nl \
"$o: $src $::teaish__Config(teaish.tcl)" "$flags(-obj): $flags(-src) $::teaish__Config(teaish.tcl)"
if {[info exists flags(-deps)]} { if {[info exists flags(-deps)]} {
teaish-make-add " " [join $flags(-deps)] teaish-make-add " " [join $flags(-deps)]
} }
@@ -1447,12 +1457,12 @@ proc teaish-make-obj {o src args} {
if {[info exists flags(-recipe)]} { if {[info exists flags(-recipe)]} {
teaish-make-add [string trim $flags(-recipe)] -nl teaish-make-add [string trim $flags(-recipe)] -nl
} else { } 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] set rule [teaish__cleanup_rule]
teaish-make-add \ teaish-make-add \
"clean: $rule\n$rule:\n\trm -f \"$o\"\n" "clean: $rule\n$rule:\n\trm -f \"$flags(-obj)\"\n"
} }
} }
@@ -2080,6 +2090,17 @@ proc teaish-pkginfo-set {args} {
set v $x 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 -
-tm.tcl.in { -tm.tcl.in {
if {0x30 & $::teaish__Config(pkgindex-policy)} { if {0x30 & $::teaish__Config(pkgindex-policy)} {
@@ -2517,7 +2538,7 @@ proc teaish__install {{dDest ""}} {
] { ] {
teaish__verbose 1 msg-result "Copying files to $destDir..." teaish__verbose 1 msg-result "Copying files to $destDir..."
file mkdir $destDir file mkdir $destDir
foreach f [glob -directory $srcDir *] { foreach f [glob -nocomplain -directory $srcDir *] {
if {[string match {*~} $f] || [string match "#*#" [file tail $f]]} { if {[string match {*~} $f] || [string match "#*#" [file tail $f]]} {
# Editor-generated backups and emacs lock files # Editor-generated backups and emacs lock files
continue continue

View File

@@ -99,7 +99,7 @@ proc test__affert {failMode args} {
lassign $args script msg lassign $args script msg
} }
incr ::test__Counters($what) incr ::test__Counters($what)
if {![uplevel 1 [concat expr [list $script]]]} { if {![uplevel 1 expr [list $script]]} {
if {"" eq $msg} { if {"" eq $msg} {
set msg $script set msg $script
} }
@@ -136,6 +136,40 @@ proc assert {args} {
tailcall test__affert 1 {*}$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? # @test-assert testId script ?msg?
# #
@@ -157,7 +191,7 @@ proc test-expect {testId script result} {
puts "test $testId" puts "test $testId"
set x [string trim [uplevel 1 $script]] set x [string trim [uplevel 1 $script]]
set result [string trim $result] 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>>" "\nEXPECTED: <<$result>>\nGOT: <<$x>>"
} }
@@ -169,7 +203,7 @@ proc test-expect {testId script result} {
# #
proc test-catch {cmd args} { proc test-catch {cmd args} {
if {[catch { if {[catch {
$cmd {*}$args uplevel 1 $cmd {*}$args
} rc xopts]} { } rc xopts]} {
puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc" puts "[test-current-scope] ignoring failure of: $cmd [lindex $args 0]: $rc"
return 1 return 1
@@ -177,6 +211,37 @@ proc test-catch {cmd args} {
return 0 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]} { if {![array exists ::teaish__BuildFlags]} {
array set ::teaish__BuildFlags {} array set ::teaish__BuildFlags {}
} }

View File

@@ -1,5 +1,5 @@
C Random\stypo\sfixes\sin\sJNI\sdocs. C Configure-related\sfixes\sand\sadditions,\smost\snotably\sintegration\sof\sself-tests\sfor\sproj.tcl's\sAPIs.\sTeaish\smake-install\sfixes\sbased\son\sthe\sdiscussion\sin\s[forum:87e6660191a472c5\s|\sforum\sthread\s87e6660191a472c5].
D 2025-05-30T15:46:52.989 D 2025-05-30T16:08:31.088
F .fossil-settings/binary-glob 61195414528fb3ea9693577e1980230d78a1f8b0a54c78cf1b9b24d0a409ed6a x F .fossil-settings/binary-glob 61195414528fb3ea9693577e1980230d78a1f8b0a54c78cf1b9b24d0a409ed6a x
F .fossil-settings/empty-dirs dbb81e8fc0401ac46a1491ab34a7f2c7c0452f2f06b54ebb845d024ca8283ef1 F .fossil-settings/empty-dirs dbb81e8fc0401ac46a1491ab34a7f2c7c0452f2f06b54ebb845d024ca8283ef1
F .fossil-settings/ignore-glob 35175cdfcf539b2318cb04a9901442804be81cd677d8b889fcc9149c21f239ea F .fossil-settings/ignore-glob 35175cdfcf539b2318cb04a9901442804be81cd677d8b889fcc9149c21f239ea
@@ -22,15 +22,15 @@ F autoconf/Makefile.msc f15ad424ca2820df8e39d9157965710af0a64d87773706706a12ea4f
F autoconf/README.first f1d3876e9a7852c22f275a6f06814e64934cecbc0b5b9617d64849094c1fd136 F autoconf/README.first f1d3876e9a7852c22f275a6f06814e64934cecbc0b5b9617d64849094c1fd136
F autoconf/README.txt b749816b8452b3af994dc6d607394bef3df1736d7e09359f1087de8439a52807 F autoconf/README.txt b749816b8452b3af994dc6d607394bef3df1736d7e09359f1087de8439a52807
F autoconf/auto.def 3d994f3a9cc9b712dbce92a5708570ddcf3b988141b6eb738f2ed16127a9f0ac F autoconf/auto.def 3d994f3a9cc9b712dbce92a5708570ddcf3b988141b6eb738f2ed16127a9f0ac
F autoconf/tea/Makefile.in 14c6a79ce87e10d8a35398f2d0e04e1d83a88eb52ee16ebf0eeaccf005ff84b3 F autoconf/tea/Makefile.in bf6b43eafcd18766d81a8f0085cfc9cb051d8abae9031a8e7c3f5f1246e8f166
F autoconf/tea/README.txt 656d4686c509d375f5988ff3deda94f65fe6cd8358cd55d1f1dcc7b6e2ff73aa F autoconf/tea/README.txt 656d4686c509d375f5988ff3deda94f65fe6cd8358cd55d1f1dcc7b6e2ff73aa
F autoconf/tea/_teaish.tester.tcl.in ed5445512e91c12afbbb99771efb68a23be4a046d52d61213fb5b6f010118129 F autoconf/tea/_teaish.tester.tcl.in 8253b44be88e2e3f21de95a65d3a90c2be8e70b7bdd08a5b80e337ba7402f8f1
F autoconf/tea/auto.def ce95b9450e2fa4ba5dc857e208fe10f4e6f2d737796ac3278aee6079db417529 F autoconf/tea/auto.def ce95b9450e2fa4ba5dc857e208fe10f4e6f2d737796ac3278aee6079db417529
F autoconf/tea/configure d0b12b984edca6030d1976375b80157ac78b5b90a5b4f0dcee39357f63f4a80b x F autoconf/tea/configure d0b12b984edca6030d1976375b80157ac78b5b90a5b4f0dcee39357f63f4a80b x
F autoconf/tea/doc/sqlite3.n 9a97f4f717ceab73004ea412af7960625c1cb24b5c25e4ae4c8b5d8fa4300f4e F autoconf/tea/doc/sqlite3.n 9a97f4f717ceab73004ea412af7960625c1cb24b5c25e4ae4c8b5d8fa4300f4e
F autoconf/tea/license.terms 13bd403c9610fd2b76ece0ab50c4c5eda933d523 F autoconf/tea/license.terms 13bd403c9610fd2b76ece0ab50c4c5eda933d523
F autoconf/tea/pkgIndex.tcl.in e07da6b94561f4aa382bab65b1ccceb04701b97bf59d007c1d1f20a222b22d07 F autoconf/tea/pkgIndex.tcl.in e07da6b94561f4aa382bab65b1ccceb04701b97bf59d007c1d1f20a222b22d07
F autoconf/tea/teaish.tcl 81571a9f9ae5c70735595b05586cb2de9d2aea7e32aad10417c4982f2e2f01c8 F autoconf/tea/teaish.tcl a2224762a039ed30c45cc1ce4b2fde5667fb0aa2569bb56590f5cb5d45d7410b
F autoconf/tea/teaish.test.tcl cfe94e1fb79dd078f650295be59843d470125e0cc3a17a1414c1fb8d77f4aea6 F autoconf/tea/teaish.test.tcl cfe94e1fb79dd078f650295be59843d470125e0cc3a17a1414c1fb8d77f4aea6
F autosetup/LICENSE 41a26aebdd2cd185d1e2b210f71b7ce234496979f6b35aef2cbf6b80cbed4ce4 F autosetup/LICENSE 41a26aebdd2cd185d1e2b210f71b7ce234496979f6b35aef2cbf6b80cbed4ce4
F autosetup/README.autosetup a78ff8c4a3d2636a4268736672a74bf14a82f42687fcf0631a70c516075c031e F autosetup/README.autosetup a78ff8c4a3d2636a4268736672a74bf14a82f42687fcf0631a70c516075c031e
@@ -47,13 +47,13 @@ F autosetup/cc.tcl c0fcc50ca91deff8741e449ddad05bcd08268bc31177e613a6343bbd1fd3e
F autosetup/find_tclconfig.tcl e64886ffe3b982d4df42cd28ed91fe0b5940c2c5785e126c1821baf61bc86a7e F autosetup/find_tclconfig.tcl e64886ffe3b982d4df42cd28ed91fe0b5940c2c5785e126c1821baf61bc86a7e
F autosetup/jimsh0.c 563b966c137a4ce3c9333e5196723b7ac0919140a9d7989eb440463cd855c367 F autosetup/jimsh0.c 563b966c137a4ce3c9333e5196723b7ac0919140a9d7989eb440463cd855c367
F autosetup/pkg-config.tcl 4e635bf39022ff65e0d5434339dd41503ea48fc53822c9c5bde88b02d3d952ba F autosetup/pkg-config.tcl 4e635bf39022ff65e0d5434339dd41503ea48fc53822c9c5bde88b02d3d952ba
F autosetup/proj.tcl c4a77735b57f3c016a185bff048212a197b77723f9bea6cfafe396e4b542c666 F autosetup/proj.tcl a4d7eb8d7e05328ac6202abe813da300db2fa89f1936a69f3f9d75300b4ff244
F autosetup/sqlite-config.tcl ccda82e43e377b832aae72a1678b1dc17dcaff36ed0ebbd8f0cfc88612ae8de3 F autosetup/sqlite-config.tcl ccda82e43e377b832aae72a1678b1dc17dcaff36ed0ebbd8f0cfc88612ae8de3
F autosetup/system.tcl 51d4be76cd9a9074704b584e5c9cbba616202c8468cf9ba8a4f8294a7ab1dba9 F autosetup/system.tcl 51d4be76cd9a9074704b584e5c9cbba616202c8468cf9ba8a4f8294a7ab1dba9
F autosetup/teaish/README.txt b40071e6f8506500a2f7f71d5fc69e0bf87b9d7678dd9da1e5b4d0acbf40b1ca F autosetup/teaish/README.txt b40071e6f8506500a2f7f71d5fc69e0bf87b9d7678dd9da1e5b4d0acbf40b1ca
F autosetup/teaish/core.tcl a37bd039881bc1b0adfa25808966e62108b1e8194e730f1d1e06aad7e57b1f6e F autosetup/teaish/core.tcl 8824c4c37075814a1a7613ca30c0654460779b1765c091bf3600e378c8fdf3e0
F autosetup/teaish/feature.tcl 18194fb79a24d30e5bbdeab40999616f39278b53a27525349ded033af2fd73be F autosetup/teaish/feature.tcl 18194fb79a24d30e5bbdeab40999616f39278b53a27525349ded033af2fd73be
F autosetup/teaish/tester.tcl 091745984473faea6985254b9986c6dfd0cce06f68bc515ba4afc1e6b3742fa8 F autosetup/teaish/tester.tcl 1799514c2652db49561b3386c5242b94534d1663f2cfac861a955e071895fdd0
F configure 9a00b21dfd13757bbfb8d89b30660a89ec1f8f3a79402b8f9f9b6fc475c3303a x F configure 9a00b21dfd13757bbfb8d89b30660a89ec1f8f3a79402b8f9f9b6fc475c3303a x
F contrib/sqlitecon.tcl eb4c6578e08dd353263958da0dc620f8400b869a50d06e271ab0be85a51a08d3 F contrib/sqlitecon.tcl eb4c6578e08dd353263958da0dc620f8400b869a50d06e271ab0be85a51a08d3
F doc/F2FS.txt c1d4a0ae9711cfe0e1d8b019d154f1c29e0d3abfe820787ba1e9ed7691160fcd F doc/F2FS.txt c1d4a0ae9711cfe0e1d8b019d154f1c29e0d3abfe820787ba1e9ed7691160fcd
@@ -2207,8 +2207,8 @@ F tool/version-info.c 3b36468a90faf1bbd59c65fd0eb66522d9f941eedd364fabccd7227350
F tool/warnings-clang.sh bbf6a1e685e534c92ec2bfba5b1745f34fb6f0bc2a362850723a9ee87c1b31a7 F tool/warnings-clang.sh bbf6a1e685e534c92ec2bfba5b1745f34fb6f0bc2a362850723a9ee87c1b31a7
F tool/warnings.sh 1ad0169b022b280bcaaf94a7fa231591be96b514230ab5c98fbf15cd7df842dd F tool/warnings.sh 1ad0169b022b280bcaaf94a7fa231591be96b514230ab5c98fbf15cd7df842dd
F tool/win/sqlite.vsix deb315d026cc8400325c5863eef847784a219a2f F tool/win/sqlite.vsix deb315d026cc8400325c5863eef847784a219a2f
P 22441955e03df07903b98832a60c05c53721cd67c667f6c83d5e97fcc62735ee P f63608a3847469b130e029cc569fe6f03a9053352ec43c10d69849cbab4f61c5
R 1edac9bbd25a5eccbabbe70c4bbe99ec R 45ee8fcc96567a1f284bf3c5475d67ce
U stephan U stephan
Z 90faa1c75772444c7902de216c0e90a8 Z 1517f3bde51bc97155127eadd67c114a
# Remove this line to create a well-formed Fossil manifest. # Remove this line to create a well-formed Fossil manifest.

View File

@@ -1 +1 @@
f63608a3847469b130e029cc569fe6f03a9053352ec43c10d69849cbab4f61c5 2e486f8fd011d28fdd7e59ff34f7f04374019932eb160a8c4de56a5ce01e5782