Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1039,10 +1039,21 @@ db (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? " (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")) run-id) res)) + +(define (db:get-testinfo-state-status db test-id) + (let ((res #f)) + (sqlite3:for-each-row + (lambda (run-id testname item-path state status) + ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment + (set! res (vector test-id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-"))) + db + "SELECT run_id,testname,item_path,state,status FROM tests WHERE id=?;" + test-id) + res)) ;; get a useful subset of the tests data (used in dashboard ;; use db:mintests-get-{id ,run_id,testname ...} (define (db:get-tests-for-runs-mindata db run-ids testpatt states status not-in) (db:get-tests-for-runs db run-ids testpatt states status not-in: not-in qryvals: "id,run_id,testname,state,status,event_time,item_path")) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -270,11 +270,11 @@ (next-status (cond ((eq? overall-status 'pass) this-step-status) ((eq? overall-status 'warn) (if (eq? this-step-status 'fail) 'fail 'warn)) (else 'fail))) - (next-state ;; "RUNNING") + (next-state ;; "RUNNING") ;; WHY WAS THIS CHANGED TO NOT USE (null? tal) ?? (cond ((null? tal) ;; more to run? "COMPLETED") (else "RUNNING"))) ) @@ -289,12 +289,12 @@ (if (eq? this-step-status 'warn) "Logpro warning found" #f) #f)) ((pass) (tests:test-set-status! test-id next-state "PASS" #f #f)) (else ;; 'fail - (set! rollup-status 1) ;; force fail - (tests:test-set-status! test-id next-state "FAIL" (conc "Failed at step " stepname) #f) + (set! rollup-status 1) ;; force fail, this used to be next-state but that doesn't make sense. should always be "COMPLETED" + (tests:test-set-status! test-id "COMPLETED" "FAIL" (conc "Failed at step " stepname) #f) )))) (if (and (steprun-good? logpro-used (vector-ref exit-info 2)) (not (null? tal))) (loop (car tal) (cdr tal) stepname))) (debug:print 4 "WARNING: a prior step failed, stopping at " ezstep)))))))) @@ -372,11 +372,12 @@ ;; (thread-terminate! th1) ;; Not sure if this is a good idea (thread-sleep! 1) ;; give thread th1 a chance to be done TODO: Verify this is needed. At 0.1 I was getting fail to stop, increased to total of 1.1 sec. ;; (tests:update-central-meta-info test-id cpuload diskfree minutes #f #f) (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) - (testinfo (cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) + ;; only state and status needed - use lazy routine + (testinfo (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;;;(cdb:get-test-info-by-id *runremote* test-id))) ;; )) ;; run-id test-name item-path))) ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) ;; NOTE: It should *not* be REMOTEHOSTSTART but for reasons I don't yet understand it sometimes gets stuck in that state ;; (not (equal? (db:test-get-state testinfo) "COMPLETED")) (let ((new-state (if kill-job? "KILLED" "COMPLETED") ;; (if (eq? (vector-ref exit-info 2) 0) ;; exited with "good" status ;; "COMPLETED" ;; (db:test-get-state testinfo))) ;; else preseve the state as set within the test Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5513) +(define megatest-version 1.5514) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -114,11 +114,14 @@ ;; from the cached data set the vars (hash-table-for-each vals (lambda (key val) (debug:print 2 "setenv " key " " val) - (setenv key val))) + (if (and (string? key) + (string? val)) + (setenv key val) + (debug:print 0 "ERROR: Malformed environment variable definition: var=" var ", val=" val)))) (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())) ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (setenv "MT_RUNNAME" (if inrunname inrunname (cdb:remote-run db:get-run-name-from-id #f run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*))) @@ -1000,12 +1003,12 @@ (hash-table-set! *test-meta-updated* test-name #t) (runs:update-test_meta test-name test-conf))) ;; itemdat => ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (testdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (testdat (if test-id (cdb:get-test-info-by-id *runremote* test-id) #f))) (if (not testdat) (let loop () ;; ensure that the path exists before registering the test ;; NOPE: Cannot! Don't know yet which disk area will be assigned.... ;; (system (conc "mkdir -p " new-test-path)) @@ -1012,16 +1015,16 @@ ;; ;; (open-run-close tests:register-test db run-id test-name item-path) ;; ;; NB// for the above line. I want the test to be registered long before this routine gets called! ;; - (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) + (if (not test-id)(set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path))) (if (not test-id) (begin (debug:print 2 "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) (cdb:tests-register-test *runremote* run-id test-name item-path) - (set! test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)))) + (set! test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)))) (debug:print-info 4 "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") (set! testdat (cdb:get-test-info-by-id *runremote* test-id)) (if (not testdat) (begin (debug:print-info 0 "WARNING: server is overloaded, trying again in one second") Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -555,12 +555,12 @@ (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) (waitons (tests:testqueue-get-waitons test-record)) (keep-test #t) - (test-id (cdb:remote-run db:get-test-id #f run-id test-name item-path)) - (tdat (cdb:get-test-info-by-id *runremote* test-id))) + (test-id (cdb:remote-run db:get-test-id-cached #f run-id test-name item-path)) + (tdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin ;; Look at the test state and status (if (or (and (member (db:test-get-status tdat) '("PASS" "WARN" "WAIVED" "CHECK" "SKIP")) @@ -572,12 +572,12 @@ ;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test ;; from the runnable list (if keep-test (for-each (lambda (waiton) ;; for now we are waiting only on the parent test - (let* ((parent-test-id (cdb:remote-run db:get-test-id #f run-id waiton "")) - (wtdat (cdb:get-test-info-by-id *runremote* test-id))) + (let* ((parent-test-id (cdb:remote-run db:get-test-id-cached #f run-id waiton "")) + (wtdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if (or (and (equal? (db:test-get-state wtdat) "COMPLETED") (member (db:test-get-status wtdat) '("FAIL"))) (member (db:test-get-status wtdat) '("KILLED")) (member (db:test-get-state wtdat) '("INCOMPETE"))) ;; (if (or (member (db:test-get-status wtdat) @@ -680,11 +680,11 @@ ;;====================================================================== ;; teststep-set-status! used to be here (define (test-get-kill-request test-id) ;; run-id test-name itemdat) - (let* ((testdat (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) + (let* ((testdat (cdb:remote-run db:get-testinfo-state-status #f test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) ;; run-id test-name item-path))) (and testdat (equal? (test:get-state testdat) "KILLREQ")))) (define (test:tdb-get-rundat-count tdb) (if tdb