Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -585,11 +585,11 @@ SET fail_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'fail'), pass_count=(SELECT count(id) FROM test_data WHERE test_id=? AND status like 'pass') WHERE id=?;" test-id test-id test-id) ;; if the test is not FAIL then set status based on the fail and pass counts. - (sleep 1) + (thread-sleep! 1) (sqlite3:execute db "UPDATE tests SET status=CASE WHEN (SELECT fail_count FROM tests WHERE id=?) > 0 THEN 'FAIL' Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -543,13 +543,19 @@ ;; (define (run-tests db test-names) (let* ((keys (db-get-keys db)) (keyvallst (keys->vallist keys #t)) (run-id (register-run db keys)) ;; test-name))) - (deferred '())) ;; delay running these since they have a waiton clause + (deferred '()) ;; delay running these since they have a waiton clause + (runconfigf (conc *toppath* "/runconfigs.config"))) ;; on the first pass or call to run-tests set FAILS to NOT_STARTED if ;; -keepgoing is specified + + (if (file-exists? runconfigf) + (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + (if (and (eq? *passnum* 0) (args:get-arg "-keepgoing")) (begin ;; have to delete test records where NOT_STARTED since they can cause -keepgoing to ;; get stuck due to becoming inaccessible from a failed test. I.e. if test B depends @@ -572,11 +578,11 @@ (let ((estrem (db:estimated-tests-remaining db run-id))) (if (and (> estrem 0) (eq? *globalexitstatus* 0)) (begin (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") - (sleep 3) + (thread-sleep! 3) (run-waiting-tests db) (loop (+ numtimes 1))))))))) ;; VERY INEFFICIENT! Move stuff that should be done once up to calling proc (define (run-one-test db run-id test-name keyvallst) @@ -607,12 +613,12 @@ (items (hash-table-ref/default test-conf "items" '())) (itemstable (hash-table-ref/default test-conf "itemstable" '())) (allitems (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) - '(()))) ;; a list with one null list is a test with no items - (runconfigf (conc *toppath* "/runconfigs.config"))) + '(())))) ;; a list with one null list is a test with no items +;; (runconfigf (conc *toppath* "/runconfigs.config"))) (debug:print 1 "items: ") (if (>= *verbosity* 1)(pp allitems)) (if (>= *verbosity* 5) (begin (print "items: ")(pp (item-assoc->item-list items)) @@ -662,13 +668,16 @@ (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (change-directory test-path) ;; this block is here only to inform the user early on - (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + + ;; NB// Moving the setting of runconfig.config vars to *before* the + ;; the calling of each test. + ;; (if (file-exists? runconfigf) + ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) (case (if (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat)) @@ -748,11 +757,11 @@ ;; what is needed is to check the db for tests that have failed less than ;; N times or never been started and kick them off again (let loop ((waiting-test-names (hash-table-keys *waiting-queue*))) (cond ((not (runs:can-run-more-tests db)) - (sleep 2) + (thread-sleep! 2) (loop waiting-test-names)) ((null? waiting-test-names) (debug:print 1 "All tests launched")) (else (set! numtries (+ numtries 1)) @@ -871,11 +880,11 @@ (let ((estrem (db:estimated-tests-remaining db run-id))) (if (and (> estrem 0) (eq? *globalexitstatus* 0)) (begin (debug:print 1 "Keep going, estimated " estrem " tests remaining to run, will continue in 3 seconds ...") - (sleep 3) + (thread-sleep! 3) (run-waiting-tests db) (loop (+ numtimes 1))))))))) (define (run:test db run-id runname test-name keyvallst item-patts flags) (debug:print 1 "Launching test " test-name) @@ -909,12 +918,12 @@ (items (hash-table-ref/default test-conf "items" '())) (itemstable (hash-table-ref/default test-conf "itemstable" '())) (allitems (if (or (not (null? items))(not (null? itemstable))) (append (item-assoc->item-list items) (item-table->item-list itemstable)) - '(()))) ;; a list with one null list is a test with no items - (runconfigf (conc *toppath* "/runconfigs.config"))) + '(())))) ;; a list with one null list is a test with no items + ;; (runconfigf (conc *toppath* "/runconfigs.config"))) (debug:print 1 "items: ") (if (>= *verbosity* 1)(pp allitems)) (if (>= *verbosity* 5) (begin (print "items: ")(pp (item-assoc->item-list items)) @@ -973,13 +982,13 @@ (debug:print 0 "WARNING: Couldn't register test " test-name " with item path " item-path ", skipping") (if (not (null? tal)) (loop (car tal)(cdr tal))))))) (change-directory test-path) ;; this block is here only to inform the user early on - (if (file-exists? runconfigf) - (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) - (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) + ;; (if (file-exists? runconfigf) + ;; (setup-env-defaults db runconfigf run-id *already-seen-runconfig-info*) + ;; (debug:print 0 "WARNING: You do not have a run config file: " runconfigf)) (debug:print 4 "run-id: " run-id " test-name: " test-name " item-path: " item-path " testdat: " (test:get-status testdat) " test-state: " (test:get-state testdat)) (case (if force ;; (args:get-arg "-force") 'NOT_STARTED (if testdat (string->symbol (test:get-state testdat))