Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -1761,34 +1761,37 @@ run-id)))) ;; Update run_stats for given run_id ;; input data is a list (state status count) ;; -(define (db:update-run-stats dbstruct run-id stats) - (mutex-lock! *db-transaction-mutex*) - (db:with-db - dbstruct - #f - #t - (lambda (dbdat db) - ;; remove previous data - - (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) - (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) - (res - (sqlite3:with-transaction - db - (lambda () - (for-each - (lambda (dat) - (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) - (apply sqlite3:execute stmt2 run-id dat)) - stats))))) - (sqlite3:finalize! stmt1) - (sqlite3:finalize! stmt2) - (mutex-unlock! *db-transaction-mutex*) - res)))) +(define (db:update-run-stats dbstruct run-id stats-in) + (let* ((stats (if (list? stats-in) + stats-in + (db:get-raw-run-stats run-id)))) + (mutex-lock! *db-transaction-mutex*) + (db:with-db + dbstruct + #f + #t + (lambda (dbdat db) + ;; remove previous data + + (let* ((stmt1 (sqlite3:prepare db "DELETE FROM run_stats WHERE run_id=? AND state=? AND status=?;")) + (stmt2 (sqlite3:prepare db "INSERT INTO run_stats (run_id,state,status,count) VALUES (?,?,?,?);")) + (res + (sqlite3:with-transaction + db + (lambda () + (for-each + (lambda (dat) + (sqlite3:execute stmt1 run-id (car dat)(cadr dat)) + (apply sqlite3:execute stmt2 run-id dat)) + stats))))) + (sqlite3:finalize! stmt1) + (sqlite3:finalize! stmt2) + (mutex-unlock! *db-transaction-mutex*) + res))))) (define (db:get-main-run-stats dbstruct run-id) (db:with-db dbstruct #f ;; this data comes from main Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -442,11 +442,19 @@ (if (and (common:file-exists? fulln) (file-execute-access? fulln)) fulln runscript))))) ;; assume it is on the path (check-work-area (lambda () - ;; NFS might not have propagated the directory meta data to the run host - give it time if needed + ;; + ;; NFS might not have propagated the + ;; directory meta data to the run host - give it + ;; time if needed + ;; + ;; alternatively - if nonfs is set, find a working + ;; directory using [host-disks] and copy from + ;; the homehost using rsync + ;; (let loop ((count 0)) (if (or (common:directory-exists? work-area) (> count 10)) (change-directory work-area) (begin @@ -460,11 +468,13 @@ "INFO: we are expecting to be in directory " work-area "\n" " but we are actually in the directory " (current-directory) "\n" " doing another change dir.") (change-directory work-area))) - ;; spot check that the files in testpath are available. Too often NFS delays cause problems here. + ;; spot check that the files in testpath are available. + ;; Too often NFS delays cause problems here. + (let ((files (glob (conc testpath "/*"))) (bad-files '())) (for-each (lambda (fullname) (let* ((fname (pathname-strip-directory fullname)) @@ -581,12 +591,10 @@ ;; (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) ;; these may be needed by the launching process ;; one of these is defunct/redundant ... (if (not (launch:setup force-reread: #t)) (begin (debug:print 0 *default-log-port* "Failed to setup, exiting") - ;; (sqlite3:finalize! db) - ;; (sqlite3:finalize! tdb) (exit 1))) ;; validate that the test run area is available (check-work-area) ;; still need to go back to run area home for next couple steps @@ -593,15 +601,15 @@ (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? + + ;; CHANGE THIS: Do NOT read the runconfigs again - ONLY use the cached version (let ((rconfig (full-runconfigs-read)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: (list "default" target)))) (wconfig (read-config "waivers.config" #f #t sections: `( "default" ,target )))) ;; read the waivers config if it exists - ;; (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) (for-each (lambda (varval) @@ -611,11 +619,10 @@ (begin (safe-setenv var (configf: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 (common:file-exists? work-area) (> count 10)) @@ -625,15 +632,13 @@ (thread-sleep! 10) (loop (+ count 1))))) ;; now we can switch to the work-area? (change-directory work-area) - ;;(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 + ;; clobber things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) (let ((varpairs (string-split set-vars ","))) (debug:print 4 *default-log-port* "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) @@ -641,11 +646,10 @@ (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 @@ -659,83 +663,37 @@ (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (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_LINKTREE" (common:get-linktree)) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) - ;;(bb-check-path msg: "launch:execute post block 3") (let ((tmppath (getenv "PATH"))) (if (string-search tmppath " ") (debug:print 0 *default-log-port* "WARNING: spaces in PATH are not supported.")) (if mt-bindir-path (setenv "PATH" (conc tmppath":"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") (let ((blacklist (configf:lookup *configdat* "setup" "blacklistvars"))) (if blacklist (let ((vars (string-split blacklist))) (save-environment-as-files "megatest" ignorevars: vars) (for-each (lambda (var) (unsetenv var)) vars)) (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) - - ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here - (if (args:get-arg "-xterm") (set! fullrunscript "xterm") (if (and fullrunscript (common:file-exists? fullrunscript) (not (file-execute-access? fullrunscript))) (system (conc "chmod ug+x " fullrunscript)))) (launch:extract-scripts-logpro work-area test-name item-path tconfigreg) - -;;;;; ;; We are about to actually kick off the test -;;;;; ;; so this is a good place to remove the records for -;;;;; ;; any previous runs -;;;;; ;; (db:test-remove-steps db run-id testname itemdat) -;;;;; ;; now is also a good time to write the .testconfig file -;;;;; (let* ((tconfig-fname (conc work-area "/.testconfig")) -;;;;; (tconfig-tmpfile (conc tconfig-fname ".tmp")) -;;;;; (tconfig (tests:get-testconfig test-name item-path tconfigreg #t force-create: #t)) ;; 'return-procs))) -;;;;; (scripts (configf:get-section tconfig "scripts")) -;;;;; (precmd (configf:lookup tconfig ) -;;;;; ;; create .testconfig file -;;;;; (configf:write-alist tconfig tconfig-tmpfile) -;;;;; (file-move tconfig-tmpfile tconfig-fname #t) -;;;;; (delete-file* ".final-status") -;;;;; -;;;;; ;; extract scripts from testconfig and write them to files in test run dir -;;;;; (for-each -;;;;; (lambda (scriptdat) -;;;;; (match scriptdat -;;;;; ((name content) -;;;;; (with-output-to-file name -;;;;; (lambda () -;;;;; (print content) -;;;;; (change-file-mode name (bitwise-ior perm/irwxg perm/irwxu))))) -;;;;; (else -;;;;; (debug:print-info 0 "Invalid script definiton found in [scripts] section of testconfig. \"" scriptdat "\"")))) -;;;;; scripts)) - ;; - (let* ((m (make-mutex)) (kill-job? #f) (exit-info (make-launch:einf pid: #t exit-status: #t exit-code: #t rollup-status: 0)) ;; pid exit-status exit-code (i.e. process was successfully run) rollup-status (job-thread #f) ;; (keep-going #t) @@ -766,15 +724,20 @@ (thread-join! th2) (debug:print-info 0 *default-log-port* "Megatest execute of test " test-name ", item path " item-path " complete. Notifying the db ...") (debug:print-info 2 *default-log-port* "exit-info = " exit-info) (hash-table-set! misc-flags 'keep-going #f) (thread-join! th1) - (thread-sleep! 1) ;; givbe 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. + (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. (mutex-lock! m) (let* ((item-path (item-list->path itemdat)) + + ;; REMOVE this call and change this section to get killrequest from disk file + ;; FUTURE: the test will start a tcp server to listen for kill requests + ;; only state and status needed - use lazy routine (testinfo (rmt:get-testinfo-state-status run-id test-id))) + ;; Am I completed? (if (member (db:test-get-state testinfo) '("REMOTEHOSTSTART" "RUNNING")) (let ((new-state (if kill-job? "KILLED" "COMPLETED")) (new-status (cond ((not (launch:einf-exit-status exit-info)) "FAIL") ;; job failed to run ... (vector-ref exit-info 1) @@ -781,43 +744,41 @@ ((eq? (launch:einf-rollup-status exit-info) 0) ;; (vector-ref exit-info 3) ;; if the current status is AUTO then defer to the calculated value (i.e. leave this AUTO) (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO" "PASS")) ((eq? (launch:einf-rollup-status exit-info) 1) "FAIL") ;; (vector-ref exit-info 3) ((eq? (launch:einf-rollup-status exit-info) 2) ;; (vector-ref exit-info 3) - ;; if the current status is AUTO the defer to the calculated value but qualify (i.e. make this AUTO-WARN) + + ;; if the current status is AUTO the defer to the calculated value but + ;; qualify (i.e. make this AUTO-WARN) + (if (equal? (db:test-get-status testinfo) "AUTO") "AUTO-WARN" "WARN")) ((eq? (launch:einf-rollup-status exit-info) 3) "CHECK") ((eq? (launch:einf-rollup-status exit-info) 4) "WAIVED") ((eq? (launch:einf-rollup-status exit-info) 5) "ABORT") ((eq? (launch:einf-rollup-status exit-info) 6) "SKIP") - (else "FAIL"))) - ) ;; (db:test-get-status testinfo))) + (else "FAIL")))) (debug:print-info 0 *default-log-port* "Test exited in state=" (db:test-get-state testinfo) ", setting state/status based on exit code of " (launch:einf-exit-status exit-info) " and rollup-status of " (launch:einf-rollup-status exit-info)) ;; Leave a .final-status file for each sub-test (tests:save-final-status run-id test-id) (tests:test-set-status! run-id test-id new-state new-status - (args:get-arg "-m") #f) - ;; need to update the top test record if PASS or FAIL and this is a subtest - ;; NO NEED TO CALL set-state-status-and-roll-up-items HERE, THIS IS DONE IN set-state-status-and-roll-up-items called by tests:test-set-status! - ) - ) - + (args:get-arg "-m") #f))) ;; for automated creation of the rollup html file this is a good place... (if (not (equal? item-path "")) (tests:summarize-items run-id test-id test-name #f)) - ;; BUG was this meant to be the antecnt of the if above? - ;; BUG was this meant to be the antecnt of the if above? + ;; BUG was this meant to be the antecedent of the if above? (tests:summarize-test run-id test-id) ;; don't force - just update if no ;; Leave a .final-status file for the top level test (tests:save-final-status run-id test-id) - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) ;; end of let* + + ;; WHAT IS THIS FOR? TWO CALLS BACK TO SERVER? + (rmt:update-run-stats run-id 'run)) ;; (rmt:get-raw-run-stats run-id))) ;; end of let* (mutex-unlock! m) (launch:end-of-run-check run-id ) (debug:print 2 *default-log-port* "Output from running " fullrunscript ", pid " (launch:einf-pid exit-info) " in work area " work-area ":\n====\n exit code " (launch:einf-exit-code exit-info) "\n" "====\n") @@ -824,19 +785,17 @@ (let* ((testrec (rmt:get-testinfo-state-status run-id test-id))) (set! test-status (db:test-get-status testrec)) (set! test-state (db:test-get-state testrec))) - ;; If the propagate-exit-code option has been set in the megatest config, and the test status matches the list, set the exit code to 1. - + ;; If the propagate-exit-code option has been set in the megatest config + ;; and the test status matches the list, set the exit code to 1. (if (and propagate-exit-code (string=? propagate-exit-code "yes") (member test-status propagate-status-list)) (begin (debug:print 1 *default-log-port* "Setting exit status to 1 because of test status of " test-status) - (set! *globalexitstatus* 1) - ) - ) + (set! *globalexitstatus* 1))) (if postcmd (begin (setenv "MT_TEST_STATE" test-state) (setenv "MT_TEST_STATUS" test-status) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -2657,19 +2657,15 @@ ;;PJH remove record from db no need to cleanup directory (case mode ((remove-data-only)(mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) (db:test-get-state test)(db:test-get-status test) #f)) ((archive-remove) (mt:test-set-state-status-by-id (db:test-get-run_id test)(db:test-get-id test) "ARCHIVED" #f #f)) - (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test)))) - - ) - ) - ) + (else (rmt:delete-test-records (db:test-get-run_id test) (db:test-get-id test))))))) (if (not (null? tal)) (loop (car tal)(cdr tal))))))) - (rmt:update-run-stats run-id (rmt:get-raw-run-stats run-id))) + (rmt:update-run-stats run-id 'run)) ;; (rmt:get-raw-run-stats run-id))) ((kill-runs) ;; RUNNING -> KILLREQ ;; LAUNCHED,RUNNING,REMOTEHOSTSTART -> NOT STARTED (cond ((and has-subrun (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))) Index: tests/longruntest/tests/test1/testconfig ================================================================== --- tests/longruntest/tests/test1/testconfig +++ tests/longruntest/tests/test1/testconfig @@ -24,13 +24,13 @@ (for x in $(seq 20);do echo "step$x sleep $x" done) > #{getenv MT_RUN_AREA_HOME}/steps.config [logpro] -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors + (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) + (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) + (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors # Test requirements are specified here [requirements] # waiton setup priority 0 Index: tests/longruntest/tests/test2/testconfig ================================================================== --- tests/longruntest/tests/test2/testconfig +++ tests/longruntest/tests/test2/testconfig @@ -15,25 +15,25 @@ # You should have received a copy of the GNU General Public License # along with Megatest. If not, see . # Add additional steps here. Format is "stepname script" [ezsteps] -[include #{getenv MT_RUNAREAHOME}/steps.config] +[include #{getenv MT_RUN_AREA_HOME}/steps.config] # Test requirements are specified here [requirements] waiton test1 priority 0 # Iteration for your tests are controlled by the items section [items] -LANDTYPE desert plains forest jungle beach +LANDTYPE desert [logpro] -(expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) -(expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) -(expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors + (expect:ignore in "LogFileBody" < 99 "Ignore the word error in comments" #/^\/\/.*error/) + (expect:warning in "LogFileBody" = 0 "Any warning" #/warn/) + (expect:error in "LogFileBody" = 0 "Any error" (list #/ERROR/ #/error/)) ;; but disallow any other errors # test_meta is a section for storing additional data on your test [test_meta] author matt owner matt ADDED tests/longruntest/withmt Index: tests/longruntest/withmt ================================================================== --- /dev/null +++ tests/longruntest/withmt @@ -0,0 +1,5 @@ +#!/bin/bash + +export PATH="$PWD/../../bin:$PATH" + +exec "$@"