Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -76,22 +76,27 @@ (read-config include-file res allow-system environ-patt: environ-patt) (loop (read-line inp) curr-section-name #f #f))) (section-rx ( x section-name ) (loop (read-line inp) section-name #f #f)) (key-sys-pr ( x key cmd ) (if allow-system (let ((alist (hash-table-ref/default res curr-section-name '())) - (val (let* ((cmdres (cmd-run->list cmd)) - (status (cadr cmdres)) - (res (car cmdres))) - (if (not (eq? status 0)) - (begin - (debug:print 0 "ERROR: problem with " inl ", return code " status) - (exit 1))) - (if (null? res) - "" - (string-intersperse res " "))))) + (val-proc (lambda () + (let* ((cmdres (cmd-run->list cmd)) + (status (cadr cmdres)) + (res (car cmdres))) + (if (not (eq? status 0)) + (begin + (debug:print 0 "ERROR: problem with " inl ", return code " status) + (exit 1))) + (if (null? res) + "" + (string-intersperse res " ")))))) (hash-table-set! res curr-section-name - (config:assoc-safe-add alist key val)) + (config:assoc-safe-add alist + key + (if (eq? allow-system 'return-procs) + val + (val)))) (loop (read-line inp) curr-section-name #f #f)) (loop (read-line inp) curr-section-name #f #f))) (key-val-pr ( x key val ) (let* ((alist (hash-table-ref/default res curr-section-name '())) (envar (and environ-patt (string-match (regexp environ-patt) curr-section-name))) (realval (if envar Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -113,10 +113,11 @@ reviewed TIMESTAMP, iterated TEXT DEFAULT '', avg_runtime REAL, avg_disk REAL, tags TEXT DEFAULT '', + jobgroup TEXT DEFAULT 'default', CONSTRAINT test_meta_constraint UNIQUE (testname));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, @@ -207,10 +208,13 @@ (patch-db)) ((< mver 1.29) (db:set-var db "MEGATEST_VERSION" 1.29) (sqlite3:execute db "ALTER TABLE test_steps ADD COLUMN logfile TEXT DEFAULT '';") (sqlite3:execute db "ALTER TABLE tests ADD COLUMN shortdir TEXT DEFAULT '';")) + ((< mver 1.36) + (db:set-var db "MEGATEST_VERSION" 1.36) + (sqlite3:execute db "ALTER TABLER test_meta ADD COLUMN jobgroup TEXT DEFAULT 'default';")) ((< mver megatest-version) (db:set-var db "MEGATEST_VERSION" megatest-version)))))) ;;====================================================================== ;; meta get and set vars @@ -416,10 +420,23 @@ (lambda (count) (set! res count)) db "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART';") res)) + +(define (db:get-count-tests-running-in-jobgroup db jobgroup) + (if (not jobgroup) + 0 ;; + (let ((res 0)) + (sqlite3:for-each-row + (lambda (count) + (set! res count)) + db + "SELECT count(id) FROM tests WHERE state = 'RUNNING' OR state = 'LAUNCHED' OR state = 'REMOTEHOSTSTART' + AND testname in (SELECT testname FROM test_meta WHERE jobgroup=?;" + jobgroup) + res))) ;; done with run when: ;; 0 tests in LAUNCHED, NOT_STARTED, REMOTEHOSTSTART, RUNNING (define (db:estimated-tests-remaining db run-id) (let ((res 0)) @@ -694,10 +711,38 @@ (begin (set! ever-seen #t) (if (not (and (equal? (db:test-get-state test) "COMPLETED") (member (db:test-get-status test) '("PASS" "WARN" "CHECK")))) (set! result (cons waitontest-name result)))))) + tests) + (if (not ever-seen)(set! result (cons waitontest-name result))))) + waiton) + (delete-duplicates result)))) + +;; the new prereqs calculation, looks also at itempath if specified +;; all prereqs must be met: +;; if prereq test with itempath='' is COMPLETED and PASS, WARN, CHECK, or WAIVED then prereq is met +;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met +(define (db:get-prereqs-not-met db run-id waiton ref-item-path) + (if (null? waiton) + '() + (let* ((unmet-pre-reqs '()) + (tests (db-get-tests-for-run db run-id #f #f '() '())) + (result '())) + (for-each (lambda (waitontest-name) + (let ((ever-seen #f)) + (for-each (lambda (test) + (if (equal? waitontest-name (db:test-get-testname test)) + (let* ((state (db:test-get-state test)) + (status (db:test-get-status test)) + (item-path (db:test-get-item-path test)) + (is-completed (equal? state "COMPLETED")) + (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED"))) + (same-itempath (equal? ref-item-path item-path))) + (set! ever-seen #t) + (if (or ( + (set! result (cons waitontest-name result)))))) tests) (if (not ever-seen)(set! result (cons waitontest-name result))))) waiton) (delete-duplicates result)))) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.34) +(define megatest-version 1.36) Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -94,26 +94,38 @@ (for-each (lambda (item) (debug:print 2 "setenv " (car item) " " (cadr item)) (setenv (car item) (cadr item))) itemdat)) -(define (runs:can-run-more-tests db) - (let ((num-running (db:get-count-tests-running db)) - (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs"))) +(define (runs:can-run-more-tests db test-record) + (let* ((tconfig (tests:testqueue-get-testconfig test-record)) + (jobgroup (config-lookup tconfig "requirements" "jobgroup")) + (num-running (db:get-count-tests-running db)) + (num-running-in-jobgroup (db:get-count-tests-running-in-jobgroup db jobgroup)) + (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) + (job-group-limit (config-lookup *configdat* "jobgroups" jobgroup))) (debug:print 2 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) (if (not (eq? 0 *globalexitstatus*)) #f - (if (or (not max-concurrent-jobs) - (and max-concurrent-jobs - (string->number max-concurrent-jobs) - (not (>= num-running (string->number max-concurrent-jobs))))) - #t - (begin - (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running - ", max_concurrent_jobs: " max-concurrent-jobs) - #f))))) - + (let ((can-not-run-more (cond + ;; if max-concurrent-jobs is set and the number running is greater + ;; than it than cannot run more jobs + ((and max-concurrent-jobs + (string->number max-concurrent-jobs) + (>= num-running (string->number max-concurrent-jobs))) + (debug:print 0 "WARNING: Max running jobs exceeded, current number running: " num-running + ", max_concurrent_jobs: " max-concurrent-jobs) + #t) + ;; if job-group-limit is set and number of jobs in the group is greater + ;; than the limit then cannot run more jobs of this kind + ((and job-group-limit + (>= num-running-in-jobgroup job-group-limit)) + (debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup + " in " jobgroup " exceeded, will not run " (tests:testqueue-get-testname test-record)) + #t) + (else #f)))) + (not can-not-run-more))))) ;;====================================================================== ;; New methodology. These routines will replace the above in time. For ;; now the code is duplicated. This stuff is initially used in the monitor ;; based code. @@ -155,11 +167,12 @@ (define (runs:run-tests db target runname test-patts item-patts user flags) (let* ((keys (db-get-keys db)) (keyvallst (keys:target->keyval keys target)) (run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) ;; test-name))) (deferred '()) ;; delay running these since they have a waiton clause - (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) + ;; keepgoing is the defacto modality now, will add hit-n-run a bit later + ;; (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) (test-names '()) (runconfigf (conc *toppath* "/runconfigs.config")) (required-tests '()) (test-records (make-hash-table))) @@ -196,19 +209,18 @@ ;; on test A but test B reached the point on being registered as NOT_STARTED and test ;; A failed for some reason then on re-run using -keepgoing the run can never complete. (db:delete-tests-in-state db run-id "NOT_STARTED") (db:set-tests-state-status db run-id test-names #f "FAIL" "NOT_STARTED" "FAIL"))) - (set! *passnum* (+ *passnum* 1)) - ;; now add non-directly referenced dependencies (i.e. waiton) (if (not (null? test-names)) (let loop ((hed (car test-names)) - (tal (cdr test-names))) - (let* ((config (test:get-testconfig hed #f)) + (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc + (let* ((config (test:get-testconfig hed 'return-procs)) (waitons (string-split (let ((w (config-lookup config "requirements" "waiton"))) - (if w w ""))))) + (if w w "")))) + (items (items:get-items-from-config config))) (if (not (hash-table-ref/default test-records hed #f)) (hash-table-set! test-records hed (vector hed config waitons (config-lookup "requirements" "priority") #f))) (for-each (lambda (waiton) (if (and waiton (not (member waiton test-names))) @@ -220,216 +232,192 @@ (if (not (null? remtests)) (loop (car remtests)(cdr remtests))))))) (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 test-records))) +(define (runs:run-tests-queue test-records keyvallist) ;; At this point the list of parent tests is expanded ;; NB// Should expand items here and then insert into the run queue. - (let loop ((numtimes 0)) - (for-each - (lambda (test-record) - ;; need to inspect the items field tests:testqueue-get-items - ;; - ;; if #f then no items for this test, check prereqs and launch - ;; - ;; else if list, then have items - ;; - ;; if proc then eval it. - ;; - (let ((items (items:get-items-from-config tconfig))) - (if (runs:can-run-more-tests db test-record) ;; now needs to look at the test group - (run:test db run-id runname test-name keyvallst item-patts flags) - )) - (tests:sort-by-priority-and-waiton test-records)) - ;; (run-waiting-tests db) - (if keepgoing - (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 ...") - (thread-sleep! 3) - (run-waiting-tests db) - (loop (+ numtimes 1))))))))) - -(define (run:test db run-id runname test-name keyvallst item-patts flags) + (let ((sorted-testnames (tests:sort-by-priority-and-waiton test-records))) + (let loop (; (numtimes 0) ;; shouldn't need this + (hed (car sorted-test-names)) + (tal (cdr sorted-test-names))) + (let* ((test-record (hash-table-ref test-records hed)) + (tconfig (tests:testqueue-get-testconfig test-record)) + (waitons (tests:testqueue-get-waitons test-record)) + (priority (tests:testqueue-get-priority test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) + (items (tests:testqueue-get-items test-record)) + (item-path (item-list->path itemdat))) + (cond + ((not items) ;; when false the test is ok to be handed off to launch + (let ((have-resources (runs:can-run-more-tests db test-record)) ;; look at the test jobgroup and tot jobs running + (prereqs-not-met (db:get-prereqs-not-met db run-id waiton item-path))) + (if (and have-resources + (null? prereqs-not-met)) + ;; no loop - drop though and use the loop at the bottom + (run:test db run-id runname keyvallst test-record flags) + ;; else the run is stuck, temporarily or permanently + (let ((newtal (append tal (list hed)))) + ;; couldn't run, take a breather + (thread-sleep! 1) + (loop (car tal)(cdr tal)))))) + + ;; case where an items came in as a list been processed + ((and (list? items) ;; thus we know our items are already calculated + (not itemdat)) ;; and not yet expanded into the list of things to be done + (if (>= *verbosity* 1)(pp items)) + ;; (if (>= *verbosity* 5) + ;; (begin + ;; (print "items: ") (pp (item-assoc->item-list items)) + ;; (print "itemstable: ")(pp (item-table->item-list itemstable)))) + (for-each + (lambda (my-itemdat) + (let* ((new-test-record (vector-copy! test-record (make-tests:testqueue))) + (my-item-path (item-list->path my-itemdat)) + (item-matches (if item-patts ;; here we are filtering for matches with -itempatt + (let ((res #f)) ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % + (for-each + (lambda (patt) + (if (string-search (glob->regexp + (string-translate patt "%" "*")) + item-path) + (set! res #t))) + (string-split item-patts ",")) + res) + #t))) + (if item-matches ;; yes, we want to process this item + (begin + (tests:testqueue-set-items! new-test-record #f) + (tests:testqueue-set-itemdat! new-test-record my-itemdat) + (set! tal (cons (conc hed "/" my-item-path) tal)))))) ;; since these are itemized create new test names testname/itempath + items) + (loop (car tal)(cdr tal))) + + ;; if items is a proc then need to evaluate, get the list and loop - but only do that if + ;; resources exist to kick off the job + ((procedure? items) + (if (runs:can-run-more-tests db test-record) + (let ((items-list (items))) + (if (list? items-list) + (begin + (tests:testqueue-set-items test-record items-list) + (loop hed tal)) + (begin + (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this") + (exit 1)))) + (let ((newtal (append tal (list hed)))) + ;; if can't run more tests, lets take a breather + (thread-sleep! 1) + (loop (car newtal)(cdr newtal))))) + + ;; this case should not happen, added to help catch any bugs + ((and (list? items) itemdat) + (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this") + (exit 1))) + + ;; we get here on "drop through" - loop for next test in queue + (if (null? tal) + (debug:print 1 "INFO: All tests launched") + (loop (car tal)(cdr tal))))))) + +(define (run:test db run-id runname keyvallst test-record flags) (debug:print 1 "Launching test " test-name) ;; All these vars might be referenced by the testconfig file reader (setenv "MT_TEST_NAME" test-name) ;; (setenv "MT_RUNNAME" runname) (set-megatest-env-vars db run-id) ;; these may be needed by the launching process (change-directory *toppath*) - (let* ((test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... - (test-configf (conc test-path "/testconfig")) - (testexists (and (file-exists? test-configf)(file-read-access? test-configf))) - (test-conf (if testexists (read-config test-configf #f #t) (make-hash-table))) - (waiton (let ((w (config-lookup test-conf "requirements" "waiton"))) - (if (string? w)(string-split w)'()))) + (let* ((test-name (tests:testqueue-get-testname test-record)) + (test-path (conc *toppath* "/tests/" test-name)) ;; could use test:get-testconfig here ... + (test-conf (tests:testqueue-get-testconfig test-record)) + (itemdat (tests:testqueue-get-itemdat test-record)) (force (hash-table-ref/default flags "-force" #f)) (rerun (hash-table-ref/default flags "-rerun" #f)) - (keepgoing (hash-table-ref/default flags "-keepgoing" #f)) - ;; Are these tags still used? I don't think so... - ;;(tags (let ((t (config-lookup test-conf "setup" "tags"))) - ;; ;; we want our tags to be separated by commas and fully delimited by commas - ;; ;; so that queries with "like" can tie to the commas at either end of each tag - ;; ;; while also allowing the end user to freely use spaces and commas to separate tags - ;; (if (string? t)(string-substitute (regexp "[,\\s]+") "," (conc "," t ",") #t) - ;; '())))) - ) - (if (not testexists) - ;; if the test is ill defined spit out an error but keep going (different from how done previously - (debug:print 0 "ERROR: Can't find config file " test-configf) - ;; put top vars into convenient variables and open the db - (let* (;; db is always at *toppath*/db/megatest.db - (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"))) - (debug:print 1 "items: ") - (if (>= *verbosity* 1)(pp allitems)) - (if (>= *verbosity* 5) - (begin - (print "items: ")(pp (item-assoc->item-list items)) - (print "itemstable: ")(pp (item-table->item-list itemstable)))) - - ;; Comments are loaded by the test run, not at launch time (in general) - ;;(if (args:get-arg "-m") - ;; (db:set-comment-for-run db run-id (args:get-arg "-m"))) - - ;; Here is where the test_meta table is best updated - (runs:update-test_meta db test-name test-conf) - - ;; braindead work-around for poorly specified allitems list BUG!!! FIXME - (if (null? allitems)(set! allitems '(()))) - (let loop ((itemdat (car allitems)) - (tal (cdr allitems))) - ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) - ;; Handle lists of items - (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) - (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 #f) - (num-running (db:get-count-tests-running db)) - (max-concurrent-jobs (config-lookup *configdat* "setup" "max_concurrent_jobs")) - (parent-test (and (not (null? items))(equal? item-path ""))) - (single-test (and (null? items) (equal? item-path ""))) - (item-test (not (equal? item-path ""))) - ;; look through all the item-patts if defined, format is patt1,patt2,patt3 ... wildcard is % - (item-matches (if item-patts - (let ((res #f)) - (for-each - (lambda (patt) - (if (string-search (glob->regexp - (string-translate patt "%" "*")) - item-path) - (set! res #t))) - (string-split item-patts ",")) - res) - #t))) - (debug:print 3 "max-concurrent-jobs: " max-concurrent-jobs ", num-running: " num-running) - (if (and item-matches (runs:can-run-more-tests db)) - (begin - (let loop2 ((ts (db:get-test-info db run-id test-name item-path)) ;; #f) - (ct 0)) - (if (and (not ts) - (< ct 10)) - (begin - (register-test db run-id test-name item-path) - ;; Why did I set the comment here?!? POSSIBLE BUG BUT I'M REMOVING IT FOR NOW 10/23/2011 - ;; (db:test-set-comment db run-id test-name item-path "") - (loop2 (db:get-test-info db run-id test-name item-path) - (+ ct 1))) - (if ts - (set! testdat ts) - (begin - (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 - - ;; Moving this to the run calling block - - ;; (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)) - 'failed-to-insert)) - ((failed-to-insert) - (debug:print 0 "ERROR: Failed to insert the record into the db")) - ((NOT_STARTED COMPLETED) - (debug:print 6 "Got here, " (test:get-state testdat)) - (let ((runflag #f)) - (cond - ;; i.e. this is the parent test to a suite of items, never "run" it - (parent-test - (set! runflag #f)) - ;; -force, run no matter what - (force (set! runflag #t)) - ;; NOT_STARTED, run no matter what - ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) - ;; not -rerun and PASS, WARN or CHECK, do no run - ((and (or (not rerun) - keepgoing) - (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) - (set! runflag #f)) - ;; -rerun and status is one of the specifed, run it - ((and rerun - (let ((rerunlst (string-split rerun ","))) ;; FAIL, - (member (test:get-status testdat) rerunlst))) - (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 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 \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) - (let* ((get-prereqs-cmd (lambda () - (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... - (launch-cmd (lambda () - (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags))) - (testrundat (list get-prereqs-cmd launch-cmd))) - (if (or force - (let ((preqs-not-yet-met ((car testrundat)))) - (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) - (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... - (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host - (begin - (print "ERROR: Failed to launch the test. Exiting as soon as possible") - (set! *globalexitstatus* 1) ;; - (process-signal (current-process-id) signal/kill) - ;(exit 1) - )) - (if (not keepgoing) - (hash-table-set! *waiting-queue* new-test-name testrundat))))))) - ((KILLED) - (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) - ((LAUNCHED REMOTEHOSTSTART RUNNING) - (if (> (- (current-seconds)(+ (db:test-get-event_time testdat) - (db:test-get-run_duration testdat))) - 100) ;; i.e. no update for more than 100 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)) - (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)))))) - (if (not (null? tal)) - (loop (car tal)(cdr tal))))))))) + (keepgoing (hash-table-ref/default flags "-keepgoing" #f))) + + ;; Here is where the test_meta table is best updated + (runs:update-test_meta db test-name test-conf) + + ;; (lambda (itemdat) ;;; ((ripeness "overripe") (temperature "cool") (season "summer")) + (let* ((item-path (item-list->path itemdat)) ;; (string-intersperse (map cadr itemdat) "/")) + (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 #f) + (test-info (db:get-test-info db run-id test-name item-path))) + (if (not test-info)(register-test db run-id test-name item-path)) + (change-directory test-path) + (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)) + 'failed-to-insert)) + ((failed-to-insert) + (debug:print 0 "ERROR: Failed to insert the record into the db")) + ((NOT_STARTED COMPLETED) + (debug:print 6 "Got here, " (test:get-state testdat)) + (let ((runflag #f)) + (cond + ;; -force, run no matter what + (force (set! runflag #t)) + ;; NOT_STARTED, run no matter what + ((equal? (test:get-state testdat) "NOT_STARTED")(set! runflag #t)) + ;; not -rerun and PASS, WARN or CHECK, do no run + ((and (or (not rerun) + keepgoing) + (member (test:get-status testdat) '("PASS" "WARN" "CHECK"))) + (set! runflag #f)) + ;; -rerun and status is one of the specifed, run it + ((and rerun + (let ((rerunlst (string-split rerun ","))) ;; FAIL, + (member (test:get-status testdat) rerunlst))) + (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 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 \"COMPLETED\" and status \"" (test:get-status testdat) "\", use -force to override")) + (let* ((get-prereqs-cmd (lambda () + (db-get-prereqs-not-met db run-id waiton))) ;; check before running .... + (launch-cmd (lambda () + (launch-test db run-id runname test-conf keyvallst test-name test-path itemdat flags))) + (testrundat (list get-prereqs-cmd launch-cmd))) + (if (or force + (let ((preqs-not-yet-met ((car testrundat)))) + (debug:print 2 "Preqrequesites for " test-name ": " preqs-not-yet-met) + (null? preqs-not-yet-met))) ;; are there any tests that must be run before this one... + (if (not ((cadr testrundat))) ;; this is the line that launches the test to the remote host + (begin + (print "ERROR: Failed to launch the test. Exiting as soon as possible") + (set! *globalexitstatus* 1) ;; + (process-signal (current-process-id) signal/kill) + ;(exit 1) + )) + (if (not keepgoing) + (hash-table-set! *waiting-queue* new-test-name testrundat))))))) + ((KILLED) + (debug:print 1 "NOTE: " new-test-name " is already running or was explictly killed, use -force to launch it.")) + ((LAUNCHED REMOTEHOSTSTART RUNNING) + (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)) + (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 ;;====================================================================== @@ -606,11 +594,11 @@ (new-run-id (runs:register-run db keys keyvallst runname "new" "n/a" user)) (prev-tests (test:get-matching-previous-test-run-records db new-run-id "%" "%")) (curr-tests (db-get-tests-for-run db new-run-id "%" "%" '() '())) (curr-tests-hash (make-hash-table))) (db:update-run-event_time db new-run-id) - ;; index the already saved tests by testname and itempath in curr-tests-hash + ;; index the already saved tests by testname and itemdat in curr-tests-hash (for-each (lambda (testdat) (let* ((testname (db:test-get-testname testdat)) (item-path (db:test-get-item-path testdat)) (full-name (conc testname "/" item-path))) Index: test_records.scm ================================================================== --- test_records.scm +++ test_records.scm @@ -1,13 +1,16 @@ ;; make-vector-record tests testqueue testname testconfig waitons priority items -(define (make-tests:testqueue)(make-vector 5)) +(define (make-tests:testqueue)(make-vector 6 #f)) (define-inline (tests:testqueue-get-testname vec) (vector-ref vec 0)) (define-inline (tests:testqueue-get-testconfig vec) (vector-ref vec 1)) (define-inline (tests:testqueue-get-waitons vec) (vector-ref vec 2)) (define-inline (tests:testqueue-get-priority vec) (vector-ref vec 3)) +;; items: #f=no items, list=list of items remaining, proc=need to call to get items (define-inline (tests:testqueue-get-items vec) (vector-ref vec 4)) +(define-inline (tests:testqueue-get-itemdat vec) (vector-ref vec 5)) (define-inline (tests:testqueue-set-testname! vec val)(vector-set! vec 0 val)) (define-inline (tests:testqueue-set-testconfig! vec val)(vector-set! vec 1 val)) (define-inline (tests:testqueue-set-waitons! vec val)(vector-set! vec 2 val)) (define-inline (tests:testqueue-set-priority! vec val)(vector-set! vec 3 val)) (define-inline (tests:testqueue-set-items! vec val)(vector-set! vec 4 val)) +(define-inline (tests:testqueue-set-itemdat! vec val)(vector-set! vec 5 val))