Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -545,11 +545,11 @@ (process:children #f)) (original-exit exit-code))))) ;; for some switches always print the command to stderr ;; -(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status") +(if (args:any? "-run" "-runall" "-remove-runs" "-set-state-status" "-run-test") (debug:print 0 *default-log-port* (string-intersperse (argv) " "))) ;; some switches imply homehost. Exit here if not on homehost ;; (let ((homehost-required (list "-cleanup-db" "-server"))) @@ -1557,11 +1557,29 @@ ;; (run-ids (db:get-changed-run-ids since-time))) ;; ;; (rmt:get-tests-for-runs-mindata run-ids testpatt states status not-in) ;; (print (sort run-ids <)) ;; (set! *didsomething* #t))) - + +;;====================================================================== +;; run single test +;;====================================================================== +;; launch test; executed from runloop +;; should only be called by megatest, not user. +(if (args:get-arg "-internal-run-test") + (general-run-call + "-internal-run-test" + "run single test; internal use only" + (lambda (target runname keys keyvals) + (let* ((flags args:arg-hash) + (testname ) + (run:test-bootstrap target runname keys keyvals flags) + + + ) + ))) + ;;====================================================================== ;; full run ;;====================================================================== ;; get lock in db for full run for this directory @@ -1575,11 +1593,11 @@ ;; launch task ;; else ;; put task in deferred queue ;; if still ok to run tasks ;; process deferred tasks per above steps - + ;; run all tests are are Not COMPLETED and PASS or CHECK (if (or (args:get-arg "-runall") (args:get-arg "-run") (args:get-arg "-rerun-clean") (args:get-arg "-rerun-all") ADDED run-test-internal.scm Index: run-test-internal.scm ================================================================== --- /dev/null +++ run-test-internal.scm @@ -0,0 +1,191 @@ + + +(define (run:test-internal run-id run-info keyvals runname test-record flags parent-test test-registry test-path) + ;; all-tests-registry - used to determine test path + ;; All these vars might be referenced by the testconfig file reader + ;; flags are a hash of k/v pairs that could become commandline switches to a standalone version + (let* ((test-name (tests:testqueue-get-testname test-record)) + (test-waitons (tests:testqueue-get-waitons test-record)) + (test-conf (tests:testqueue-get-testconfig test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) + (force (hash-table-ref/default flags "-force" #f)) ;; ignore some red flags; should be removed + (rerun (hash-table-ref/default flags "-rerun" #f)) ;; used to decide to rerun if test already exists, always rerun (pretend not started) + (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) + (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) + (item-path "") + (db #f) + (full-test-name #f)) + + ;; setting itemdat to a list if it is #f + (if (not itemdat)(set! itemdat '())) + (set! item-path (item-list->path itemdat)) + (set! full-test-name (db:test-make-full-name test-name item-path)) + (debug:print-info 4 *default-log-port* + "\nTESTNAME: " full-test-name + "\n test-config: " (hash-table->alist test-conf) + "\n itemdat: " itemdat + ) + (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) + ;; (setenv "MT_TEST_NAME" test-name) ;; + ;; (setenv "MT_ITEMPATH" item-path) + ;; (setenv "MT_RUNNAME" runname) + (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process + (change-directory *toppath*) + + ;; BB - dropping *test-meta-updated* processing; comment mentioned handling happened but left in just-in-case. Exercising option now. + ;; ;; Here is where the test_meta table is best updated + ;; ;; Yes, another use of a global for caching. Need a better way? + ;; ;; + ;; ;; There is now a single call to runs:update-all-test_meta and this + ;; ;; per-test call is not needed. Given the delicacy of the move to + ;; ;; v1.55 this code is being left in place for the time being. + ;; ;; + ;; (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) + ;; (begin + ;; (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 (rmt:get-test-id run-id test-name item-path)) ;; ?? necessary? + (testdat (if test-id (rmt:get-test-info-by-id run-id 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)) + ;; + ;; (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! + ;; + (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) + (if (not test-id) + (begin + (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) + (rmt:register-test run-id test-name item-path) ;; + (set! test-id (rmt:get-test-id run-id test-name item-path)))) + (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") + (set! testdat (rmt:get-test-info-by-id run-id test-id)) + (if (not testdat) + (begin + (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second") + (thread-sleep! 1) + (loop))))) + (if (not testdat) ;; should NOT happen + (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id)) + (set! test-id (db:test-get-id testdat)) + (if (common:file-exists? test-path) + (change-directory test-path) + (begin + (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") + (change-directory *toppath*))) + + + (case (if force ;; (args:get-arg "-force") + 'NOT_STARTED + (if testdat + (string->symbol (test:get-state testdat)) + 'failed-to-insert)) + ((failed-to-insert) ;; should never happen now + (debug:print-error 0 *default-log-port* "Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED DELETED INCOMPLETE) + (let ((runflag #f)) + (cond + ;; -force, run no matter what + (force (set! runflag #t)) + ;; NOT_STARTED, run no matter what + ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t)) + ;; not -rerun and PASS, WARN or CHECK, do no run + ((and (or (not rerun) + keepgoing) + ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK + (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) + (member (test:get-state testdat) '("COMPLETED")))) + (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) + (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) + (set! runflag #f)) + ;; -rerun and status is one of the specifed, run it + ((and rerun + (let* ((rerunlst (string-split rerun ",")) + (must-rerun (member (test:get-status testdat) rerunlst))) + (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) + must-rerun)) + (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path) + (set! runflag #t)) + ;; -keepgoing, do not rerun FAIL + ((and keepgoing + (member (test:get-status testdat) '("FAIL"))) + (set! runflag #f)) + ((and (not rerun) + (member (test:get-status testdat) '("FAIL" "n/a"))) + (set! runflag #t)) + (else (set! runflag #f))) + (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) + (if (not runflag) + (if (not parent-test) + (if (runs:lownoise (conc "not starting test" full-test-name) 60) + (debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) + "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) + "\" or -force to override"))) + ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are + ;; already met. + ;; This would be a great place to do the process-fork + ;; + (let ((skip-test #f) + (skip-check (configf:get-section test-conf "skip"))) + (cond + ;; Have to check for skip conditions. This one skips if there are same-named tests + ;; currently running + ((and skip-check + (configf:lookup test-conf "skip" "prevrunning")) + ;; run-ids = #f means *all* runs + (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) + (if (not (null? running-tests)) ;; have to skip + (set! skip-test "Skipping due to previous tests running")))) + ((and skip-check + (configf:lookup test-conf "skip" "fileexists")) + (if (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) + (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))) + ((and skip-check + (configf:lookup test-conf "skip" "rundelay")) + ;; run-ids = #f means *all* runs + (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) + (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) + (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex + (last-run-times (map db:mintest-get-event_time completed-tests)) + (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times))))) + (if (or (not (null? running-tests)) ;; have to skip if test is running + (> numseconds time-since-last)) + (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) + + (if skip-test + (begin + (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) + (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) + (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) ;; HERE WE GO + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill)))))))) + ((KILLED) + (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) + ((LAUNCHED REMOTEHOSTSTART RUNNING) + (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) + ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) + ;; (db:test-get-run_duration testdat))) + ;; (or incomplete-timeout + ;; 6000)) ;; i.e. no update for more than 6000 seconds + ;; (begin + ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") + ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) + ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) + (else + (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) + (case (string->symbol (test:get-state testdat)) + ((COMPLETED INCOMPLETE) + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) + (else + (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -333,11 +333,12 @@ (waitors-upon (make-hash-table)) ;; given a test, return list of tests waiting upon this test. (task-key (conc (hash-table->alist flags) " " (get-host-name) " " (current-process-id))) ;; (tdbdat (tasks:open-db)) (config-reruns (let ((x (configf:lookup *configdat* "setup" "reruns"))) (if x (string->number x) #f))) - (allowed-tests #f)) + (allowed-tests #f) + (last-loop-top-time (current-seconds))) ;; check if readonly (when readonly-mode (debug:print-error 0 *default-log-port* "megatest.db is readonly. Cannot proceed.") (exit 1)) @@ -484,11 +485,15 @@ ((hed-mode) (let ((m (config-lookup config "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) ((hed-itemized-waiton) ;; are items in hed waiting on items of waiton? (not (null? (lset-intersection eq? hed-mode '(itemmatch itemwait))))) + ((loop-delta-time) (- (current-seconds) last-loop-top-time)) + ) + (set! last-loop-top-time (current-seconds)) + (BB> "RUNLOOPTOP | cycletime="loop-delta-time" depth="(add1 (length tal))" hed="hed) (debug:print-info 8 *default-log-port* "waitons: " waitons) ;; check for hed in waitons => this would be circular, remove it and issue an ;; error (if (or (member hed waitons) (member hed waitors)) @@ -1239,11 +1244,11 @@ (debug:print 5 *default-log-port* "test-records: " test-records ", flags: " (hash-table->alist flags)) ;; Do mark-and-find clean up of db before starting runing of quue ;; ;; (rmt:find-and-mark-incomplete) - + (BB> "entered run-tests-queue") (let* ((run-info (rmt:get-run-info run-id)) (tests-info (mt:get-tests-for-run run-id #f '() '())) ;; qryvals: "id,testname,item_path")) (sorted-test-names (tests:sort-by-priority-and-waiton test-records)) (test-registry (make-hash-table)) (registry-mutex (make-mutex)) @@ -1280,11 +1285,13 @@ ;; newtal: newtal all-tests-registry: all-tests-registry ;; itemmaps: itemmaps ;; prereqs-not-met: (rmt:get-prereqs-not-met run-id waitons hed item-path mode: testmode itemmaps: itemmaps) ;; can-run-more-tests: (runs:can-run-more-tests run-id jobgroup max-concurrent-jobs) ;; look at the test jobgroup and tot jobs running - ))) + )) + + (rtq-looptop-lastvisit-time (current-seconds))) ;; Initialize the test-registery hash with tests that already have a record ;; convert state to symbol and use that as the hash value (for-each (lambda (trec) (let ((id (db:test-get-id trec)) @@ -1298,11 +1305,13 @@ (let loop ((hed (car sorted-test-names)) (tal (cdr sorted-test-names)) (reg '()) ;; registered, put these at the head of tal (reruns '())) - + (let ((cycletime (- (current-seconds) rtq-looptop-lastvisit-time))) + (BB> "RTQ LOOP TOP | cycletime="cycletime"| qdepth="(add1 (length tal))" hed="hed)) + (set! rtq-looptop-lastvisit-time (current-seconds)) (runs:incremental-print-results run-id) (if (not (null? reruns))(debug:print-info 4 *default-log-port* "reruns=" reruns)) ;; Here we mark any old defunct tests as incomplete. Do this every fifteen minutes @@ -1602,197 +1611,56 @@ (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) + + +;; NOTES: +;; - need to pickle test-record or tests:testqueue and testconfig... +;; - need to keep test-registry bookkeeping in run:test somehow... +;; - dropping *test-meta-updated* processing; comment mentioned handling happened but left in just-in-case. Exercising option now. +;; - globals to consider: +;; *test-meta-updated* ;; dropped +;; *configdat* +;; *default-log-port* +;; *toppath* +;; *globalexitstatus* +(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) + ;; run:test refactored to spawn external command to background to allow runloop to proceed without waiting for test launch to complete + ;; run:test will spawn-command to background "megatest -internal-run-test ..." + ;; which calls run:test-bootstrap which calls run:test-internal -- the old run:test + + (let* ((test-path (hash-table-ref all-tests-registry test-name)) ;; path to test definition (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... + (flag-switches ...) + (cmdline + (conc "megatest -internal-run-test -target "target + " -run-name "runname + " -test-path"test-path + " -testname "test-name + " -item-path "item-path + flag-switches + " &"))) + ;;(setenv "TARGETHOST_LOGF" logfile) + ;;(system (conc "nbfake "cmdline) + ;;(unsetenv "TARGETHOST_LOGF") + (system cmdline)) + #t) + +(define (run:test-bootstrap target runname keys keyvals flags) + (let* ((run-id ...) + (run-info ...) + (test-path (args:get-arg "-test-path")) + (run:test-internal run-id run-info keyvals runname test-record flags parent-test test-registry test-path) + )) + + + + ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step ;; -(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry all-tests-registry) - ;; All these vars might be referenced by the testconfig file reader - (let* ((test-name (tests:testqueue-get-testname test-record)) - (test-waitons (tests:testqueue-get-waitons test-record)) - (test-conf (tests:testqueue-get-testconfig test-record)) - (itemdat (tests:testqueue-get-itemdat test-record)) - (test-path (hash-table-ref all-tests-registry test-name)) ;; (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ... - (force (hash-table-ref/default flags "-force" #f)) - (rerun (hash-table-ref/default flags "-rerun" #f)) - (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - (incomplete-timeout (string->number (or (configf:lookup *configdat* "setup" "incomplete-timeout") "x"))) - (item-path "") - (db #f) - (full-test-name #f)) - - ;; setting itemdat to a list if it is #f - (if (not itemdat)(set! itemdat '())) - (set! item-path (item-list->path itemdat)) - (set! full-test-name (db:test-make-full-name test-name item-path)) - (debug:print-info 4 *default-log-port* - "\nTESTNAME: " full-test-name - "\n test-config: " (hash-table->alist test-conf) - "\n itemdat: " itemdat - ) - (debug:print 2 *default-log-port* "Attempting to launch test " full-test-name) - ;; (setenv "MT_TEST_NAME" test-name) ;; - ;; (setenv "MT_ITEMPATH" item-path) - ;; (setenv "MT_RUNNAME" runname) - (runs:set-megatest-env-vars run-id inrunname: runname testname: test-name itempath: item-path) ;; these may be needed by the launching process - (change-directory *toppath*) - - ;; Here is where the test_meta table is best updated - ;; Yes, another use of a global for caching. Need a better way? - ;; - ;; There is now a single call to runs:update-all-test_meta and this - ;; per-test call is not needed. Given the delicacy of the move to - ;; v1.55 this code is being left in place for the time being. - ;; - (if (not (hash-table-ref/default *test-meta-updated* test-name #f)) - (begin - (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 (rmt:get-test-id run-id test-name item-path)) - (testdat (if test-id (rmt:get-test-info-by-id run-id 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)) - ;; - ;; (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! - ;; - (if (not test-id)(set! test-id (rmt:get-test-id run-id test-name item-path))) - (if (not test-id) - (begin - (debug:print 2 *default-log-port* "WARN: Test not pre-created? test-name=" test-name ", item-path=" item-path ", run-id=" run-id) - (rmt:register-test run-id test-name item-path) - (set! test-id (rmt:get-test-id run-id test-name item-path)))) - (debug:print-info 4 *default-log-port* "test-id=" test-id ", run-id=" run-id ", test-name=" test-name ", item-path=\"" item-path "\"") - (set! testdat (rmt:get-test-info-by-id run-id test-id)) - (if (not testdat) - (begin - (debug:print-info 0 *default-log-port* "WARNING: server is overloaded, trying again in one second") - (thread-sleep! 1) - (loop))))) - (if (not testdat) ;; should NOT happen - (debug:print-error 0 *default-log-port* "failed to get test record for test-id " test-id)) - (set! test-id (db:test-get-id testdat)) - (if (common:file-exists? test-path) - (change-directory test-path) - (begin - (debug:print-error 0 *default-log-port* "test run path not created before attempting to run the test. Perhaps you are running -remove-runs at the same time?") - (change-directory *toppath*))) - (case (if force ;; (args:get-arg "-force") - 'NOT_STARTED - (if testdat - (string->symbol (test:get-state testdat)) - 'failed-to-insert)) - ((failed-to-insert) - (debug:print-error 0 *default-log-port* "Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED DELETED INCOMPLETE) - (let ((runflag #f)) - (cond - ;; -force, run no matter what - (force (set! runflag #t)) - ;; NOT_STARTED, run no matter what - ((member (test:get-state testdat) '("DELETED" "NOT_STARTED" "INCOMPLETE"))(set! runflag #t)) - ;; not -rerun and PASS, WARN or CHECK, do no run - ((and (or (not rerun) - keepgoing) - ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK - (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP" "WAIVED")) - (member (test:get-state testdat) '("COMPLETED")))) - (debug:print-info 2 *default-log-port* "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat)) - (hash-table-set! test-registry full-test-name 'DONOTRUN) ;; COMPLETED) - (set! runflag #f)) - ;; -rerun and status is one of the specifed, run it - ((and rerun - (let* ((rerunlst (string-split rerun ",")) - (must-rerun (member (test:get-status testdat) rerunlst))) - (debug:print-info 3 *default-log-port* "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun) - must-rerun)) - (debug:print-info 2 *default-log-port* "Rerun forced for test " test-name "/" item-path) - (set! runflag #t)) - ;; -keepgoing, do not rerun FAIL - ((and keepgoing - (member (test:get-status testdat) '("FAIL"))) - (set! runflag #f)) - ((and (not rerun) - (member (test:get-status testdat) '("FAIL" "n/a"))) - (set! runflag #t)) - (else (set! runflag #f))) - (debug:print 4 *default-log-port* "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) - (if (not runflag) - (if (not parent-test) - (if (runs:lownoise (conc "not starting test" full-test-name) 60) - (debug:print 1 *default-log-port* "NOTE: Not starting test " full-test-name " as it is state \"" (test:get-state testdat) - "\" and status \"" (test:get-status testdat) "\", use -rerun \"" (test:get-status testdat) - "\" or -force to override"))) - ;; NOTE: No longer be checking prerequisites here! Will never get here unless prereqs are - ;; already met. - ;; This would be a great place to do the process-fork - ;; - (let ((skip-test #f) - (skip-check (configf:get-section test-conf "skip"))) - (cond - ;; Have to check for skip conditions. This one skips if there are same-named tests - ;; currently running - ((and skip-check - (configf:lookup test-conf "skip" "prevrunning")) - ;; run-ids = #f means *all* runs - (let ((running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f))) - (if (not (null? running-tests)) ;; have to skip - (set! skip-test "Skipping due to previous tests running")))) - ((and skip-check - (configf:lookup test-conf "skip" "fileexists")) - (if (common:file-exists? (configf:lookup test-conf "skip" "fileexists")) - (set! skip-test (conc "Skipping due to existance of file " (configf:lookup test-conf "skip" "fileexists"))))) - ((and skip-check - (configf:lookup test-conf "skip" "rundelay")) - ;; run-ids = #f means *all* runs - (let* ((numseconds (common:hms-string->seconds (configf:lookup test-conf "skip" "rundelay"))) - (running-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("RUNNING" "REMOTEHOSTSTART" "LAUNCHED") '() #f)) - (completed-tests (rmt:get-tests-for-runs-mindata #f full-test-name '("COMPLETED" "INCOMPLETE") '("PASS" "FAIL" "ABORT") #f)) ;; ironically INCOMPLETE is same as COMPLETED in this contex - (last-run-times (map db:mintest-get-event_time completed-tests)) - (time-since-last (- (current-seconds) (if (null? last-run-times) 0 (common:max last-run-times))))) - (if (or (not (null? running-tests)) ;; have to skip if test is running - (> numseconds time-since-last)) - (set! skip-test (conc "Skipping due to previous test run less than " (configf:lookup test-conf "skip" "rundelay") " ago")))))) - - (if skip-test - (begin - (mt:test-set-state-status-by-id run-id test-id "COMPLETED" "SKIP" skip-test) - (debug:print-info 1 *default-log-port* "SKIPPING Test " full-test-name " due to " skip-test)) - (if (not (launch-test test-id run-id run-info keyvals runname test-conf test-name test-path itemdat flags)) - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill)))))))) - ((KILLED) - (debug:print 1 *default-log-port* "NOTE: " full-test-name " is already running or was explictly killed, use -force to launch it.") - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) ;; KILLED)) - ((LAUNCHED REMOTEHOSTSTART RUNNING) - (debug:print 2 *default-log-port* "NOTE: " test-name " is already running")) - ;; (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - ;; (db:test-get-run_duration testdat))) - ;; (or incomplete-timeout - ;; 6000)) ;; i.e. no update for more than 6000 seconds - ;; (begin - ;; (debug:print 0 *default-log-port* "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - ;; (tests:test-set-status! run-id test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; ;; (tests:test-set-status! test-id "INCOMPLETE" "STUCK/DEAD" "" #f)) - ;; (debug:print 2 *default-log-port* "NOTE: " test-name " is already running"))) - (else - (debug:print-error 0 *default-log-port* "Failed to launch test " full-test-name ". Unrecognised state " (test:get-state testdat)) - (case (string->symbol (test:get-state testdat)) - ((COMPLETED INCOMPLETE) - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)) - (else - (hash-table-set! test-registry (db:test-make-full-name test-name test-path) 'DONOTRUN)))))))) +(include "run-test-internal.scm") ;; temporary, will pull back in later. ;;====================================================================== ;; END OF NEW STUFF ;;======================================================================