Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -169,10 +169,11 @@ ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -167,11 +167,11 @@ "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE r.target LIKE ?;" target-patt)) -(define (pgdb:get-stats-given-target dbh ttype-id target-patt) +(define (pgdb:get-stats-given-type-target dbh ttype-id target-patt) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" "SELECT r.target,COUNT(*) AS total, @@ -179,10 +179,23 @@ SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target;" ttype-id target-patt)) + +(define (pgdb:get-stats-given-target dbh target-patt) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.target,COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;" + target-patt)) (define (pgdb:get-target-types dbh) (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) ;; Index: cgisetup/pages/home_view.scm ================================================================== --- cgisetup/pages/home_view.scm +++ cgisetup/pages/home_view.scm @@ -10,11 +10,11 @@ ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:get "target-type") "0"))) + (selected (string->number (or (s:get "target-type") "-1"))) (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) (curr-ttype (if (and selected (not (null? curr-trec))) (vector-ref (car curr-trec) 1) #f)) (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) @@ -21,29 +21,34 @@ (tfilter (or (s:get "target-filter") "%")) (targets (pgdb:get-targets-of-type dbh selected tfilter)) ;; (target (s:session-var-get "target")) ;; (target-patt (or target "%")) (row-or-col (string-split (or (s:get "row-or-col") "") ",")) - (all-data (if selected (pgdb:get-stats-given-target dbh selected tfilter) - '())) + (all-data (if (and selected + (not (eq? selected -1))) + (pgdb:get-stats-given-type-target dbh selected tfilter) + (pgdb:get-stats-given-target dbh tfilter) + )) ;; (all-data (pgdb:get-tests dbh tfilter)) (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) (s:div 'class "col_12" (s:fieldset "Area type and target filter" (s:form - 'action "home.filter" 'method "get" + 'action "home.filter" 'method "post" (s:div 'class "col_12" (s:div 'class "col_6" (s:select (map (lambda (x) - (let ((tt-id (vector-ref x 0)) - (ttype (vector-ref x 1))) - (if (eq? tt-id selected) - (list ttype tt-id ttype #t) - (list ttype tt-id ttype #f)))) - ttypes) + (if x + (let ((tt-id (vector-ref x 0)) + (ttype (vector-ref x 1))) + (if (eq? tt-id selected) + (list ttype tt-id ttype #t) + (list ttype tt-id ttype #f))) + (list "all" -1 "all" (eq? selected -1)))) + (cons #f ttypes)) 'name 'target-type)) (s:div 'class "col_4" (s:input-preserve 'name "tfilter" 'placeholder "Filter targets")) (s:div 'class "col_2" (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1683,20 +1683,28 @@ #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== +(define (bb-check-path #!key (msg "check-path: ")) + (let ((path (or (get-environment-variable "PATH") "none"))) + (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) + (if (string-match "^.*/isoenv-core/.*" path) + (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod + (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) + (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) - (with-output-to-file (conc fname ".csh") + (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) @@ -2083,10 +2091,28 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) +(define (common:faux-lock keyname) + (if (rmt:get-var keyname) + #f + (begin + (rmt:set-var keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) + +(define (common:faux-unlock keyname #!key (force #f)) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) + (begin + (if (rmt:get-var keyname) (rmt:del-var keyname)) + #t) + #f)) + + +(define (common:in-running-test?) + (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) + (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -663,25 +663,35 @@ #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (let ((dat (configf:config->alist cdat))) - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - (if (common:file-exists? fname) ;; now verify it is readable - (if (configf:read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - #f - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") - (delete-file fname)) - #f)) - #f))) + (if (common:faux-lock fname) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + #f + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + + (common:faux-unlock fname) + res) + (begin + (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) + #f))) ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -2723,11 +2723,11 @@ (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300 ) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -299,16 +299,16 @@ (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area (dbexists (file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (mtdbexists (file-exists? (conc *toppath* "/megatest.db"))) + (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) - + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath)) (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) @@ -370,11 +370,12 @@ (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) - (db:initialize-run-id-db db)))) + ;;(db:initialize-run-id-db db) + ))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) @@ -1200,21 +1201,21 @@ CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 *default-log-port* "db:initialize END"))))) - -;;====================================================================== -;; R U N S P E C I F I C D B -;;====================================================================== - -(define (db:initialize-run-id-db db) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + ;; (define (db:initialize-run-id-db db) + ;; (sqlite3:with-transaction + ;; db + ;; (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1234,18 +1235,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', @@ -1252,18 +1253,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1272,34 +1273,34 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) - db) + db)) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -399,15 +399,17 @@ (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) + ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area @@ -591,10 +593,11 @@ (begin (setenv var (config:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) + ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? work-area) (> count 10)) @@ -601,11 +604,11 @@ (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) - + ;;(bb-check-path msg: "launch:execute post block 1.5") ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) @@ -617,10 +620,11 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) + ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val @@ -636,22 +640,28 @@ (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) + ;;(bb-check-path msg: "launch:execute post block 41") (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + ;;(bb-check-path msg: "launch:execute post block 42") (set-item-env-vars itemdat) + ;;(bb-check-path msg: "launch:execute post block 43") (save-environment-as-files "megatest") + ;;(bb-check-path msg: "launch:execute post block 44") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) @@ -762,11 +772,12 @@ (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 *default-log-port* "Caching megatest.config in " tmpfile) - (configf:write-alist *configdat* tmpfile) + (if (not (common:in-running-test?)) + (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) @@ -795,12 +806,14 @@ *toppath*) (let ((res (launch:setup-body force: force areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) -(define (launch:setup-body #!key (force #f) (areapath #f)) - (if (and (eq? *configstatus* 'fulldata) *toppath*) ;; no need to reprocess +(define (launch:setup-body #!key (force-reread #f) (areapath #f)) + (if (and (eq? *configstatus* 'fulldata) + *toppath* + (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath (let* ((use-cache (common:use-cache?)) (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath (runname (common:args-get-runname)) (target (common:args-get-target)) @@ -807,13 +820,14 @@ (linktree (common:get-linktree)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" 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))) - (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir)))) + (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?))))) ;; (cxt (hash-table-ref/default *contexts* toppath #f))) ;; create our cxt for this area if it doesn't already exist ;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -857,11 +857,12 @@ (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin - (configf:write-alist data cfgf) + (if (not (common:in-running-test?)) + (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force: #t) (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig data)))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -673,10 +673,13 @@ (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) +(define (rmt:del-var varname) + (rmt:send-receive 'del-var #f (list varname))) + (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -51,10 +51,11 @@ waitons testmode newtal itemmaps prereqs-not-met) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) @@ -74,19 +75,23 @@ (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars + (hash-table-for-each vals (lambda (key val) (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") + ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit - (let fatal-loop ((count 0)) + (let fatal-loop ((count 0)) (handle-exceptions exn (let ((call-chain (get-call-chain)) (msg ((condition-property-accessor 'exn 'message) exn))) (if (< count 5) @@ -98,20 +103,23 @@ (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* (lambda ()(pp call-chain))) (exit 1)))) - (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") + (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1201,11 +1201,12 @@ (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) - (configf:write-alist tcfg tpath))) + (if (not (common:in-running-test?)) + (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records)