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,28 @@ ;; (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)) + (run:test-standalone target runname keys keyvals flags) + + + ) + ))) + ;;====================================================================== ;; full run ;;====================================================================== ;; get lock in db for full run for this directory @@ -1575,11 +1592,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") 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,21 +1611,33 @@ (if (not (vector? t)) (conc t) (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t)))) lst)) + + + +(define (run:test-standalone target runname keys keyvals flags) + (let* ((run-id ...) + (run-info ...) + + + ) + ;; 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-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)) - (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)) + (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 ... + (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)) @@ -1649,11 +1670,11 @@ (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)) + (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.... @@ -1665,11 +1686,11 @@ ;; (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) + (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 @@ -1682,16 +1703,18 @@ (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") + + + (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) 'failed-to-insert)) - ((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 @@ -1763,11 +1786,11 @@ (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)) + (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)