Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -449,11 +449,12 @@ (if rtestpatt (debug:print-info 0 "TESTPATT from runconfigs: " rtestpatt)) testpatt)) (define (common:args-get-runname) (or (args:get-arg "-runname") - (args:get-arg ":runname"))) + (args:get-arg ":runname") + (getenv "MT_RUNNAME"))) (define (common:args-get-target #!key (split #f)) (let* ((keys (keys:config-get-fields *configdat*)) (numkeys (length keys)) (target (if (args:get-arg "-reqtarg") Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -239,10 +239,11 @@ test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) +;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) (allruns (if *useserver* (rmt:get-runs runnamepatt numruns *start-run-offset* keypatts) Index: docs/manual/Makefile ================================================================== --- docs/manual/Makefile +++ docs/manual/Makefile @@ -1,8 +1,8 @@ ASCPATH = $(shell which asciidoc) -EXEPATH = $(shell realpath $(ASCPATH)) +EXEPATH = $(shell readlink -f $(ASCPATH)) BINPATH = $(shell dirname $(EXEPATH)) DISPATH = $(shell dirname $(BINPATH)) # broad_goals.csv needed_features.csv : tables/*.dat # ./refdb2csv tables Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1177,17 +1177,15 @@

Requirements section

-
-

Header

+
Header
[requirements]
-

Wait on Other Tests

# A normal waiton waits for the prior tests to be COMPLETED
@@ -1218,10 +1216,25 @@
 

 
[requirements]
 mode itemmatch
+
+
+

Overriding Enviroment Variables

+

Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar).

+
+
+
[pre-launch-env-vars]
+VAR1 value1
+
+# Get some generated settings
+[include ../generated-vars.config]
+
+# Use this trick to unset variables
+#{scheme (unsetenv "FOOBAR")}
+

Itemmap Handling

For cases were the dependent test has a similar but not identical itempath to the downstream test an itemmap can allow for itemmatch @@ -1291,11 +1304,11 @@ 

[requirements]
 waiton A B
 
 [itemmap]
 A (\d+)/aa aa/\1
-B (\d+)/bb bb/\1
+B (\d+)/bb
Testconfig for Test D
[requirements]
@@ -1317,18 +1330,19 @@
 

 
[requirements]
 # With a toplevel test you may wish to generate your list
 # of tests to run dynamically
 #
-# waiton #{shell get-valid-tests-to-run.sh}

+waiton #{shell get-valid-tests-to-run.sh}

Run time limit

-
runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s
+
[requirements]
+runtimelim 1h 2m 3s  # this will automatically kill the test if it runs for more than 1h 2m and 3s

Skip

A test with a skip section will conditional skip running.

@@ -1485,10 +1499,53 @@ # <testsuite>/<creationdate> # Within the archive the data is structured like this: # <target>/<runname>/<test>/ archive0 /mfs/myarchive-data/adisk1
+ + +
+

Handling Environment Variables

+
+

It is often necessary to capture and or manipulate environment +variables. Megatest has some facilities built in to help.

+
+

Capture variables

+
+
Commands
+
+
# capture the current enviroment into a db called envdat.db under
+# the context "before"
+megatest -envcap before
+
+# capture the current environment into a db called startup.db with
+# context "after"
+megatest -envcap after startup.db
+
+# write the diff from before to after
+megatest -envdelta before-after -dumpmode bash
+
+

Dump modes include bash, csh and config. You can include config data +into megatest.config or runconfigs.config.

+
+
Example of generating and using config data
+
+
megatest -envcap original
+# do some stuff here
+megatest -envcap munged
+megatest -envdelta original-munged -dumpmode ini -o modified.config
+
+

Then in runconfigs.config

+
+
Example of using modified.config in a testconfig
+
+
cat testconfig
+
+[pre-launch-env-vars]
+[include modified.config]
+
+

Programming API

@@ -1656,11 +1713,10 @@
Index: docs/manual/reference.txt ================================================================== --- docs/manual/reference.txt +++ docs/manual/reference.txt @@ -89,13 +89,11 @@ ------------------- Requirements section ~~~~~~~~~~~~~~~~~~~~ -Header -^^^^^^ - +.Header ------------------- [requirements] ------------------- Wait on Other Tests @@ -132,10 +130,26 @@ ------------------- [requirements] mode itemmatch ------------------- + +Overriding Enviroment Variables +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Override variables before starting the test. Can include files (perhaps generated by megatest -envdelta or similar). + +-------------------- +[pre-launch-env-vars] +VAR1 value1 + +# Get some generated settings +[include ../generated-vars.config] + +# Use this trick to unset variables +#{scheme (unsetenv "FOOBAR")} +-------------------- Itemmap Handling ~~~~~~~~~~~~~~~~ For cases were the dependent test has a similar but not identical @@ -186,11 +200,12 @@ [requirements] waiton A B [itemmap] A (\d+)/aa aa/\1 -B (\d+)/bb -------------------- +B (\d+)/bb +---------------------- .Testconfig for Test D ---------------------- [requirements] waiton C @@ -384,10 +399,54 @@ # / # Within the archive the data is structured like this: # /// archive0 /mfs/myarchive-data/adisk1 -------------- + +Handling Environment Variables +------------------------------ + +It is often necessary to capture and or manipulate environment +variables. Megatest has some facilities built in to help. + +Capture variables +~~~~~~~~~~~~~~~~~ + +.Commands +------------------------------ +# capture the current enviroment into a db called envdat.db under +# the context "before" +megatest -envcap before + +# capture the current environment into a db called startup.db with +# context "after" +megatest -envcap after startup.db + +# write the diff from before to after +megatest -envdelta before-after -dumpmode bash +------------------------------ + +Dump modes include bash, csh and config. You can include config data +into megatest.config or runconfigs.config. + +.Example of generating and using config data +------------------------------ +megatest -envcap original +# do some stuff here +megatest -envcap munged +megatest -envdelta original-munged -dumpmode ini -o modified.config +------------------------------ + +Then in runconfigs.config + +.Example of using modified.config in a testconfig +------------------------------ +cat testconfig + +[pre-launch-env-vars] +[include modified.config] +------------------------------ Programming API --------------- These routines can be called from the megatest repl. Index: docs/manual/server.png ================================================================== --- docs/manual/server.png +++ docs/manual/server.png cannot compute difference between binary files Index: env.scm ================================================================== --- env.scm +++ env.scm @@ -27,11 +27,11 @@ (set-busy-handler! db (busy-timeout 10000)) db)) ;; save vars in given context, this is NOT incremental by default ;; -(define (env:save-env-vars db context #!key (incremental #f)) +(define (env:save-env-vars db context #!key (incremental #f)(vardat #f)) (with-transaction db (lambda () ;; first clear out any vars for this context (if (not incremental)(exec (sql db "DELETE FROM envvars WHERE context=?") context)) @@ -39,40 +39,83 @@ (lambda (varval) (let ((var (car varval)) (val (cdr varval))) (if incremental (exec (sql db "DELETE FROM envvars WHERE context=? AND var=?") context var)) (exec (sql db "INSERT INTO envvars (context,var,val) VALUES (?,?,?)") context var val))) - (get-environment-variables))))) + (if vardat + (hash-table->alist vardat) + (get-environment-variables)))))) -;; apply contexts to current environment +;; merge contexts in the order given ;; - each context is applied in the given order ;; - variables in the paths list are split on the separator and the components ;; merged using simple delta addition +;; returns a hash of the merged vars +;; +(define (env:merge-contexts db basecontext contexts paths) + (let ((result (make-hash-table))) + (for-each + (lambda (context) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var + (if (and (hash-table-ref/default results var #f) + (assoc var paths)) ;; this var is a path and there is a previous path + (let ((sep (cadr (assoc var paths)))) + (env:merge-path-envvar sep (hash-table-ref results var) valb)) + valb))))) + (sql db "SELECT var,val FROM envvars WHERE context=?") + context)) + contexts) + result)) + +;; get list of removed variables between two contexts +;; +(define (env:get-removed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contexta contextb) + result)) + +;; get list of variables added to contextb from contexta +;; +(define (env:get-added db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars WHERE context=? AND var NOT IN (SELECT var FROM envvars WHERE context=?)") + contextb contexta) + result)) + +;; get list of variables in both contexta and contexb that have been changed ;; -(define (env:apply-contexts db basecontext contexts paths outputf formats) - - (for-each - (lambda (context) - (query - (for-each-row - (lambda (row) - (let ((var (car row)) - (vala (cadr row)) - (valb (caddr row))) - ;;(print "var: " var " vala: " vala " valb" valb " paths: " paths) - (if (assoc var paths) ;; this var is a PATH - (let ((current (get-environment-variable var))) ;; use this NOT vala - ;;(pp paths) - ;;(pp var) - (env:process-path-envvar var (cadr (assoc var paths)) current valb)) - (begin - (setenv var valb)))))) - (sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=? AND a.val != b.val") - ;;(sql db "SELECT b.var,a.val,b.val FROM envvars AS a JOIN envvars AS b ON a.var=b.var WHERE a.context=? AND b.context=?") - basecontext context)) - contexts)) - +(define (env:get-changed db contexta contextb) + (let ((result (make-hash-table))) + (query + (for-each-row + (lambda (row) + (let ((var (car row)) + (val (cadr row))) + (hash-table-set! result var val)))) + (sql db "SELECT var,val FROM envvars AS a WHERE context=? AND val != (SELECT val FROM envvars WHERE var=a.var AND context=?)") + contexta contextb) + result)) + +;; (define (env:blind-merge l1 l2) (if (null? l1) l2 (if (null? l2) l1 (cons (car l1) (cons (car l2) (env:blind-merge (cdr l1) (cdr l2))))))) @@ -88,13 +131,10 @@ ;; (print "AFTER: " (string-intersperse pathb-parts "\n ")) ;; (print "COMMON: " (string-intersperse common-parts "\n ")) (string-intersperse final separator))) (define (env:process-path-envvar varname separator patha pathb) - (begin - (print "Process-path-envvar: " varname) - ) (let ((newpath (env:merge-path-envvar separator patha pathb))) (setenv varname newpath))) (define (env:have-context db context) (> (query fetch-value (sql db "SELECT count(id) FROM envvars WHERE context=?") context) @@ -101,5 +141,71 @@ 0)) ;; this is so the calling block does not need to import sql-de-lite (define (env:close-database db) (close-database db)) + +(define (env:lazy-hash-table->alist indat) + (if (hash-table? indat) + (let ((dat (hash-table->alist indat))) + (if (null? dat) + #f + dat)) + #f)) + +(define (env:print added removed changed) + (let ((a (env:lazy-hash-table->alist added)) + (r (env:lazy-hash-table->alist removed)) + (c (env:lazy-hash-table->alist changed))) + (case (if (args:get-arg "-dumpmode") + (string->symbol (args:get-arg "-dumpmode")) + 'bash) + ((bash) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unset " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "export " (car dat) "=" (cdr dat))) + (hash-table->alist changed))))) + ((csh) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "unsetenv " (car dat))) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print "setenv " (car dat) " " (cdr dat))) + (hash-table->alist changed))))) + ((config ini) + (if a + (begin + (print "# Added vars") + (map (lambda (dat)(print (car dat) " " (cdr dat))) + (hash-table->alist added)))) + (if r + (begin + (print "# Removed vars") + (map (lambda (dat)(print "#{scheme (unsetenv \"" (car dat) "\")}")) + (hash-table->alist removed)))) + (if c + (begin + (print "# Changed vars") + (map (lambda (dat)(print (car dat) " " (cdr dat))) + (hash-table->alist changed))))) + (else + (debug:print 0 "ERROR: No dumpmode specified, use -dumpmode [bash|csh|config]"))))) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -245,11 +245,11 @@ (loop (+ count 1))))) (let ((sighand (lambda (signum) ;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting (if (eq? signum signal/stop) - (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) + (debug:print 0 "ERROR: attempt to STOP process. Exiting.")) (set! *time-to-exit* #t) (print "Received signal " signum ", cleaning up before exit. Please wait...") (let ((th1 (make-thread (lambda () (tests:test-force-state-status! run-id test-id "INCOMPLETE" "KILLED") (print "Killed by signal " signum ". Exiting") @@ -295,11 +295,11 @@ (change-directory *toppath*) ;; NOTE: Current order is to process runconfigs *before* setting the MT_ vars. This ;; seems non-ideal but could well break stuff ;; BUG? BUG? BUG? - + (let ((rconfig (full-runconfigs-read))) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) ;; (setup-env-defaults (conc *toppath* "/runconfigs.config") run-id (make-hash-table) keyvals target) ;; (set-run-config-vars run-id keyvals target) ;; (db:get-target db run-id)) ;; Now have runconfigs data loaded, set environment vars (for-each (lambda (section) @@ -431,12 +431,28 @@ (if ezsteps (let* ((testconfig ;; (read-config (conc work-area "/testconfig") #f #t environ-patt: "pre-launch-env-vars")) ;; FIXME??? is allow-system ok here? ;; NOTE: it is tempting to turn off force-create of testconfig but dynamic ;; ezstep names need a full re-eval here. (tests:get-testconfig test-name tconfigreg #t force-create: #t)) ;; 'return-procs))) - (ezstepslst (hash-table-ref/default testconfig "ezsteps" '()))) - (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (ezstepslst (if (hash-table? testconfig) + (hash-table-ref/default testconfig "ezsteps" '()) + #f))) + (if testconfig + (hash-table-set! *testconfigs* test-name testconfig) ;; cached for lazy reads later ... + (begin + ;; got here but there are race condiitions - re-do all setup and try one more time + (if (launch:setup-for-run) + (begin + (launch:cache-config) + (set! testconfig (full-runconfigs-read))) ;; redunantly redundant, but does it resolve the race? + (debug:print 0 "WARNING: no testconfig found for " test-name " in search path:\n " + (string-intersperse (tests:get-tests-search-path *configdat*) "\n "))))) + ;; after all that, still no testconfig? Time to abort + (if (not testconfig) + (begin + (debug:print 0 "ERROR: Failed to resolve megatest.config, runconfigs.config and testconfig issues. Giving up now") + (exit 1)))s (if (not (file-exists? ".ezsteps"))(create-directory ".ezsteps")) ;; if ezsteps was defined then we are sure to have at least one step but check anyway (if (not (> (length ezstepslst) 0)) (debug:print 0 "ERROR: ezsteps defined but ezstepslst is zero length") (let loop ((ezstep (car ezstepslst)) @@ -654,15 +670,17 @@ (define (launch:cache-config) ;; if we have a linktree and -runtests and -target and the directory exists dump the config ;; to megatest-(current-seconds).cfg and symlink it to megatest.cfg (if (and *configdat* (or (args:get-arg "-run") - (args:get-arg "-runtests"))) + (args:get-arg "-runtests") + (args:get-arg "-execute"))) (let* ((linktree (get-environment-variable "MT_LINKTREE")) (target (common:args-get-target)) (runname (or (args:get-arg "-runname") - (args:get-arg ":runname"))) + (args:get-arg ":runname") + (getenv "MT_RUNNAME"))) (fulldir (conc linktree "/" target "/" runname))) (debug:print-info 0 "Have -runtests with target=" target ", runname=" runname ", fulldir=" fulldir ", testpatt=" (or (args:get-arg "-testpatt") "%")) (if (file-exists? linktree) ;; can't proceed without linktree @@ -671,15 +689,37 @@ (create-directory fulldir #t)) ;; need to protect with exception handler (if (and target runname (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) - (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash))) - (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") - (configf:write-alist *configdat* tmpfile) - (system (conc "ln -sf " tmpfile " " targfile)) + (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) + (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) + (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached + (begin + (debug:print-info 0 "Caching megatest.config in " fulldir "/.megatest.cfg") + (configf:write-alist *configdat* tmpfile) + (system (conc "ln -sf " tmpfile " " targfile)))) ))))))) + +;; gather available information, if legit read configs in this order: +;; +;; if have cache; +;; read it a return it +;; else +;; megatest.config (do not cache) +;; runconfigs.config (cache if all vars avail) +;; megatest.config (cache if all vars avail) +;; +(define (launch:setup #!key (force #f)) + (let* ((runname (common:args-get-runname)) + (target (common:args-get-target)) + (linktree (or (getenv "MT_LINKTREE") + (if *configdat* (configf:lookup *configdat* "setup" "linktree") #f))) + (rundir (if (and runname target linktree)(conc linktree "/" target "/" runname) #f)) + (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) + (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash)))) + #f)) (define (get-best-disk confdat testconfig) (let* ((disks (or (and testconfig (hash-table-ref/default testconfig "disks" #f)) (hash-table-ref/default confdat "disks" #f))) (minspace (let ((m (configf:lookup confdat "setup" "minspace"))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -233,10 +233,11 @@ "-port" "-extract-ods" "-pathmod" "-env2file" "-envcap" + "-envdelta" "-setvars" "-set-state-status" "-set-run-status" "-debug" ;; for *verbosity* > 2 "-gen-megatest-test" @@ -312,14 +313,18 @@ "-q" ;; quiet 0, errors/warnings only ) args:arg-hash 0)) +;; Add args that use remargs here +;; (if (and (not (null? remargs)) (not (or - (args:get-arg "-runstep")) - ;; add more args that use remargs here + (args:get-arg "-runstep") + (args:get-arg "-envcap") + (args:get-arg "-envdelta") + ) )) (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; @@ -662,10 +667,53 @@ ;; (print ((rpc:procedure 'testing (car host-port)(cadr host-port)))) ;; (case (server:get-transport) ;; ((http)(http:ping run-id host-port)) ;; ((rpc) (rpc:procedure 'server:login (car host-port)(cadr host-port));; *toppath*)) ;; (rpc-transport:ping run-id (car host-port)(cadr host-port))) ;; (else (debug:print 0 "ERROR: No transport set")(exit))))) + +;;====================================================================== +;; Capture, save and manipulate environments +;;====================================================================== + +;; NOTE: Keep these above the section where the server or client code is setup + +(let ((envcap (args:get-arg "-envcap"))) + (if envcap + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs))))) + (env:save-env-vars db envcap) + (env:close-database db) + (set! *didsomething* #t)))) + +;; delta "language" will eventually be res=a+b-c but for now it is just res=a-b +;; +(let ((envdelta (args:get-arg "-envdelta"))) + (if envdelta + (let ((match (string-split envdelta "-")));; (string-match "([a-z0-9_]+)=([a-z0-9_\\-,]+)" envdelta))) + (if (not (null? match)) + (let* ((db (env:open-db (if (null? remargs) "envdat.db" (car remargs)))) + ;; (resctx (cadr match)) + ;; (equn (caddr match)) + (parts match) ;; (string-split equn "-")) + (minuend (car parts)) + (subtraend (cadr parts)) + (added (env:get-added db minuend subtraend)) + (removed (env:get-removed db minuend subtraend)) + (changed (env:get-changed db minuend subtraend))) + ;; (pp (hash-table->alist added)) + ;; (pp (hash-table->alist removed)) + ;; (pp (hash-table->alist changed)) + (if (args:get-arg "-o") + (with-output-to-file + (args:get-arg "-o") + (lambda () + (env:print added removed changed))) + (env:print added removed changed)) + (env:close-database db) + (set! *didsomething* #t)) + (debug:print 0 "ERROR: Parameter to -envdelta should be new=star-end"))))) + + ;;====================================================================== ;; Start the server - can be done in conjunction with -runall or -runtests (one day...) ;; we start the server if not running else start the client thread ;;====================================================================== @@ -679,37 +727,37 @@ (string->number (args:get-arg "-run-id"))))) (if run-id (begin (server:launch run-id) (set! *didsomething* #t)) - (debug:print 0 "ERROR: server requires run-id be specified with -run-id")))) + (debug:print 0 "ERROR: server requires run-id be specified with -run-id"))) ;; Not a server? This section will decide how to communicate ;; ;; Setup client for all expect listed here - ;; (if (null? (lset-intersection - ;; equal? - ;; (hash-table-keys args:arg-hash) - ;; '("-list-servers" - ;; "-stop-server" - ;; "-show-cmdinfo" - ;; "-list-runs" - ;; "-ping"))) - ;; (if (launch:setup-for-run) - ;; (let ((run-id (and (args:get-arg "-run-id") - ;; (string->number (args:get-arg "-run-id"))))) - ;; ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) - ;; ;; if not list or kill then start a client (if appropriate) - ;; (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") - ;; (eq? (length (hash-table-keys args:arg-hash)) 0)) - ;; (debug:print-info 1 "Server connection not needed") - ;; (begin - ;; ;; (if run-id - ;; ;; (client:launch run-id) - ;; ;; (client:launch 0) ;; without run-id we'll start a server for "0" - ;; #t - ;; )))))) + (if (null? (lset-intersection + equal? + (hash-table-keys args:arg-hash) + '("-list-servers" + "-stop-server" + "-show-cmdinfo" + "-list-runs" + "-ping"))) + (if (launch:setup-for-run) + (let ((run-id (and (args:get-arg "-run-id") + (string->number (args:get-arg "-run-id"))))) + ;; (set! *fdb* (filedb:open-db (conc *toppath* "/db/paths.db"))) + ;; if not list or kill then start a client (if appropriate) + (if (or (args-defined? "-h" "-version" "-gen-megatest-area" "-gen-megatest-test") + (eq? (length (hash-table-keys args:arg-hash)) 0)) + (debug:print-info 1 "Server connection not needed") + (begin + ;; (if run-id + ;; (client:launch run-id) + ;; (client:launch 0) ;; without run-id we'll start a server for "0" + #t + )))))) ;; MAY STILL NEED THIS ;; (set! *megatest-db* (make-dbr:dbstruct path: *toppath* local: #t)))))))))) (if (or (args:get-arg "-list-servers") @@ -779,24 +827,41 @@ (json-write targets)) (else (debug:print 0 "ERROR: dump output format " (args:get-arg "-dumpmode") " not supported for -list-targets"))) (set! *didsomething* #t))) +;; cache the runconfigs in $MT_LINKTREE/$MT_TARGET/$MT_RUNNAME/.runconfig +;; (define (full-runconfigs-read) - (let* ((keys (rmt:get-keys)) - (target (common:args-get-target)) - (key-vals (if target (keys:target->keyval keys target) #f)) - (sections (if target (list "default" target) #f)) - (data (begin - (setenv "MT_RUN_AREA_HOME" *toppath*) - (if key-vals - (for-each (lambda (kt) - (setenv (car kt) (cadr kt))) - key-vals)) - (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) - data)) - + (let* ((rundir (if (and (getenv "MT_LINKTREE")(getenv "MT_TARGET")(getenv "MT_RUNNAME")) + (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME")) + #f)) + (cfgf (if rundir (conc rundir "/.runconfig." megatest-version "-" megatest-fossil-hash) #f))) + (if (and cfgf + (file-exists? cfgf) + (file-write-access? cfgf)) + (configf:read-alist cfgf) + (let* ((keys (rmt:get-keys)) + (target (common:args-get-target)) + (key-vals (if target (keys:target->keyval keys target) #f)) + (sections (if target (list "default" target) #f)) + (data (begin + (setenv "MT_RUN_AREA_HOME" *toppath*) + (if key-vals + (for-each (lambda (kt) + (setenv (car kt) (cadr kt))) + key-vals)) + (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) + (if (and rundir ;; have all needed variabless + (directory-exists? rundir) + (file-write-access? rundir)) + (begin + (configf:write-alist data cfgf) + ;; force re-read of megatest.config - this resolves circular references between megatest.config + (launch:setup-for-run force: #t) + (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig + data)))) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup-for-run))) (push-directory *toppath*) (let ((data (full-runconfigs-read))) @@ -1879,28 +1944,10 @@ #f ;; do all run-ids 'new2old ) (set! *didsomething* #t))) -;;====================================================================== -;; Capture, save and manipulate environments -;;====================================================================== - -(let ((envcap (args:get-arg "-envcap"))) - (if envcap - (if (substring-index "=" envcap) - (let* ((parts (string-split envcap "=")) - (fname (car parts)) - (context (cadr parts)) - (db (env:open-db fname))) - (env:save-env-vars db context) - (env:close-database db) - (set! *didsomething* #t)) - (begin - (debug:print 0 "ERROR: Parameter to -envcap should be =. E.G. envdat=original, got: " envcap) - (set! *didsomething* #t))))) - ;;====================================================================== ;; Exit and clean up ;;====================================================================== (if *runremote* (close-all-connections!)) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1781,11 +1781,13 @@ (exit 3)) (else (let (;; (db #f) (keys #f)) (if (launch:setup-for-run) - (launch:cache-config) + (begin + (full-runconfigs-read) ;; cache the run config + (launch:cache-config)) ;; do not cache here - need to be sure runconfigs is processed (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! keys (keys:config-get-fields *configdat*)) ;; have enough to process -target or -reqtarg here Index: tests/fullrun/megatest.config ================================================================== --- tests/fullrun/megatest.config +++ tests/fullrun/megatest.config @@ -93,10 +93,13 @@ # -runtests automatically deletes the records for tests with the listed states on starting up a run allowing them to re-run # (nb// this is in addition to NOT_STARTED which is automatically re-run) # allow-auto-rerun INCOMPLETE ZERO_ITEMS # could add: STUCK STUCK/DEAD UNKNOWN KILLED KILLREQ PREQ_DISCARD + +# Try this +reruns 0 [validvalues] state start end 0 1 - 2 status pass fail n/a 0 1 running - 2