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,14 +689,17 @@ (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)))) ))))))) (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))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -313,17 +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") (args:get-arg "-envcap") (args:get-arg "-envdelta") ) - ;; add more args that use remargs here )) (debug:print 0 "ERROR: Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) ;; immediately set MT_TARGET if -reqtarg or -target are available ;; @@ -666,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 ;;====================================================================== @@ -683,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") @@ -783,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))) @@ -1883,49 +1944,10 @@ #f ;; do all run-ids 'new2old ) (set! *didsomething* #t))) -;;====================================================================== -;; Capture, save and manipulate environments -;;====================================================================== - -(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"))))) - ;;====================================================================== ;; 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