@@ -8,11 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18)) (import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) @@ -259,10 +259,11 @@ (if (not (null? required-tests)) (debug:print 1 "INFO: Adding " required-tests " to the run queue")) ;; NOTE: these are all parent tests, items are not expanded yet. (runs:run-tests-queue db run-id runname test-records keyvallst flags) + (if *rpc:listener* (server:keep-running db)) (debug:print 4 "INFO: All done by here"))) (define (runs:run-tests-queue db run-id runname test-records keyvallst flags) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. @@ -362,12 +363,13 @@ ;; we get here on "drop through" - loop for next test in queue (if (null? tal) (begin ;; FIXME!!!! THIS SHOULD NOT REQUIRE AN EXIT!!!!!!! - (debug:print 1 "INFO: All tests launched, exiting") - (exit 0)) + (debug:print 1 "INFO: All tests launched") + ;; (exit 0) + ) (loop (car tal)(cdr tal)))))) ;; parent-test is there as a placeholder for when parent-tests can be run as a setup step (define (run:test db run-id runname keyvallst test-record flags parent-test) ;; All these vars might be referenced by the testconfig file reader @@ -392,23 +394,29 @@ (setenv "MT_RUNNAME" runname) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) ;; Here is where the test_meta table is best updated - (runs:update-test_meta db test-name test-conf) + ;; Yes, another use of a global for caching. Need a better way? + (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 db test-name test-conf))) ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) (let* ((new-test-path (string-intersperse (cons test-path (map cadr itemdat)) "/")) (new-test-name (if (equal? item-path "") test-name (conc test-name "/" item-path))) ;; just need it to be unique - (testdat (db:get-test-info db run-id test-name item-path))) + (testdat (db:get-test-info db run-id test-name item-path)) + (test-id #f)) (if (not testdat) (begin ;; 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)) (rtests:register-test db run-id test-name item-path) (set! testdat (db:get-test-info db run-id test-name item-path)))) + (set! test-id (db:test-get-id testdat)) (change-directory test-path) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) @@ -449,11 +457,12 @@ (else (set! runflag #f))) (debug:print 6 "RUNNING => runflag: " runflag " STATE: " (test:get-state testdat) " STATUS: " (test:get-status testdat)) (if (not runflag) (if (not parent-test) (debug:print 1 "NOTE: Not starting test " new-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")) + "\" 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. (if (not (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags)) (begin (print "ERROR: Failed to launch the test. Exiting as soon as possible") @@ -465,11 +474,11 @@ (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) (db:test-get-run_duration testdat))) 600) ;; i.e. no update for more than 600 seconds (begin (debug:print 0 "WARNING: Test " test-name " appears to be dead. Forcing it to state INCOMPLETE and status STUCK/DEAD") - (test-set-status! db run-id test-name "INCOMPLETE" "STUCK/DEAD" itemdat "Test is stuck or dead" #f)) + (test-set-status! db test-id "INCOMPLETE" "STUCK/DEAD" "Test is stuck or dead" #f)) (debug:print 2 "NOTE: " test-name " is already running"))) (else (debug:print 0 "ERROR: Failed to launch test " new-test-name ". Unrecognised state " (test:get-state testdat))))))) ;;====================================================================== ;; END OF NEW STUFF @@ -571,11 +580,12 @@ ;; this wrapper is used to reduce the replication of code (define (general-run-call switchname action-desc proc) (let ((runname (args:get-arg ":runname")) (target (if (args:get-arg "-target") (args:get-arg "-target") - (args:get-arg "-reqtarg")))) + (args:get-arg "-reqtarg"))) + (th1 #f)) (cond ((not target) (debug:print 0 "ERROR: Missing required parameter for " switchname ", you must specify the target with -target") (exit 3)) ((not runname) @@ -587,12 +597,15 @@ (if (not (setup-for-run)) (begin (debug:print 0 "Failed to setup, exiting") (exit 1))) (set! db (open-db)) - (if (not (args:get-arg "-server")) - (server:client-setup db)) + (if (args:get-arg "-server") + (server:start db (args:get-arg "-server")) + (if (not (or (args:get-arg "-runall") + (args:get-arg "-runtests"))) + (server:client-setup db))) (set! keys (rdb:get-keys db)) ;; have enough to process -target or -reqtarg here (if (args:get-arg "-reqtarg") (let* ((runconfigf (conc *toppath* "/runconfigs.config")) ;; DO NOT EVALUATE ALL (runconfig (read-config runconfigf #f #f environ-patt: #f))) @@ -611,10 +624,11 @@ ;; Extract out stuff needed in most or many calls ;; here then call proc (let* ((keynames (map key:get-fieldname keys)) (keyvallst (keys->vallist keys #t))) (proc db target runname keys keynames keyvallst))) + (if th1 (thread-join! th1)) (sqlite3:finalize! db) (set! *didsomething* #t)))))) ;;====================================================================== ;; Rollup runs