@@ -2399,99 +2399,96 @@ ;; not-in #t = above behaviour, #f = must match ;; mode: ;; 'dashboard - use state = 'COMPLETED' AND status in ( statuses ) OR state in ( states ) ;; (define (db:get-tests-for-run dbstruct run-id testpatt states statuses offset limit not-in sort-by sort-order qryvals last-update mode) - (if (not (number? run-id)) - (begin ;; no need to treat this as an error by default - (debug:print 4 *default-log-port* "WARNING: call to db:get-tests-for-run with bad run-id=" run-id) - ;; (print-call-chain (current-error-port)) - '()) - (let* ((qryvalstr (case qryvals - ((shortlist) "id,run_id,testname,item_path,state,status") - ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") - (else qryvals))) - (res '()) - ;; if states or statuses are null then assume match all when not-in is false - (states-qry (if (null? states) - #f - (conc " state " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('")) - (string-intersperse states "','") - "')"))) - (statuses-qry (if (null? statuses) - #f - (conc " status " - (if (eq? mode 'dashboard) - " IN ('" - (if not-in - " NOT IN ('" - " IN ('") ) - (string-intersperse statuses "','") - "')"))) - (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") - (if states-qry - (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") - ""))) - (states-statuses-qry - (cond - ((and states-qry statuses-qry) - (case mode - ((dashboard) - (if not-in - (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " - " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") - (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " - " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) - (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) - (states-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) - (else (conc " AND " states-qry)))) - (statuses-qry - (case mode - ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) - (else (conc " AND " statuses-qry)))) - (else ""))) - (tests-match-qry (tests:match->sqlqry testpatt)) - (qry (conc "SELECT " qryvalstr + (let* ((qryvalstr (case qryvals + ((shortlist) "id,run_id,testname,item_path,state,status") + ((#f) db:test-record-qry-selector) ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment") + (else qryvals))) + (res '()) + ;; if states or statuses are null then assume match all when not-in is false + (states-qry (if (null? states) + #f + (conc " state " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('")) + (string-intersperse states "','") + "')"))) + (statuses-qry (if (null? statuses) + #f + (conc " status " + (if (eq? mode 'dashboard) + " IN ('" + (if not-in + " NOT IN ('" + " IN ('") ) + (string-intersperse statuses "','") + "')"))) + (interim-qry (conc " AND " (if not-in "NOT " "") "( state='COMPLETED' " (if statuses-qry (conc " AND " statuses-qry " ) ") " ) ") + (if states-qry + (conc (if not-in " AND " " OR ") states-qry ) ;; " ) ") + ""))) + (states-statuses-qry + (cond + ((and states-qry statuses-qry) + (case mode + ((dashboard) + (if not-in + (conc " AND (state='COMPLETED' AND status NOT IN ('" (string-intersperse statuses "','") "')) " + " OR (state != 'COMPLETED' AND state NOT IN ('" (string-intersperse states "','") "')) ") + (conc " AND (state='COMPLETED' AND status IN ('" (string-intersperse statuses "','") "')) " + " OR (state NOT IN ('COMPLETED','DELETED') AND state IN ('" (string-intersperse states "','") "')) "))) + (else (conc " AND ( " states-qry " AND " statuses-qry " ) ")))) + (states-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " state IN ('" (string-intersperse states "','") "') ")) ;; interim-qry) + (else (conc " AND " states-qry)))) + (statuses-qry + (case mode + ((dashboard) (conc " AND " (if not-in "NOT " "") " status IN ('" (string-intersperse statuses "','") "') ")) ;; interim-qry) + (else (conc " AND " statuses-qry)))) + (else ""))) + (tests-match-qry (tests:match->sqlqry testpatt)) + (qry (conc "SELECT " qryvalstr + (if run-id " FROM tests WHERE run_id=? " - (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? - states-statuses-qry - (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") - (if last-update (conc " AND last_update >= " last-update " ") "") - (case sort-by - ((rundir) " ORDER BY length(rundir) ") - ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) - ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) - ((event_time) " ORDER BY event_time ") - (else (if (string? sort-by) - (conc " ORDER BY " sort-by " ") - " "))) - (if sort-order sort-order " ") - (if limit (conc " LIMIT " limit) " ") - (if offset (conc " OFFSET " offset) " ") - ";" - ))) - (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) - (db:with-db dbstruct run-id #f - (lambda (db) - (sqlite3:for-each-row - (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) - (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) - db - qry - run-id - ))) - (case qryvals - ((shortlist)(map db:test-short-record->norm res)) - ((#f) res) - (else res))))) + " FROM tests WHERE ? > 0 ") ;; should work? + (if last-update " " " AND state != 'DELETED' ") ;; if using last-update we want deleted tests? + states-statuses-qry + (if tests-match-qry (conc " AND (" tests-match-qry ") ") "") + (if last-update (conc " AND last_update >= " last-update " ") "") + (case sort-by + ((rundir) " ORDER BY length(rundir) ") + ((testname) (conc " ORDER BY testname " (if sort-order (conc sort-order ",") "") " item_path ")) + ((statestatus) (conc " ORDER BY state " (if sort-order (conc sort-order ",") "") " status ")) + ((event_time) " ORDER BY event_time ") + (else (if (string? sort-by) + (conc " ORDER BY " sort-by " ") + " "))) + (if sort-order sort-order " ") + (if limit (conc " LIMIT " limit) " ") + (if offset (conc " OFFSET " offset) " ") + ";" + ))) + (debug:print-info 8 *default-log-port* "db:get-tests-for-run run-id=" run-id ", qry=" qry) + (db:with-db dbstruct run-id #f + (lambda (db) + (sqlite3:for-each-row + (lambda (a . b) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) + (set! res (cons (apply vector a b) res))) ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration final-logf comment) res))) + db + qry + (or run-id 1) ;; 1 > 0 , for the case where we are seeking tests matching criteral for all runs + ))) + (case qryvals + ((shortlist)(map db:test-short-record->norm res)) + ((#f) res) + (else res)))) (define (db:test-short-record->norm inrec) ;; "id,run_id,testname,item_path,state,status" ;; "id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment (vector (vector-ref inrec 0) ;; id @@ -3864,77 +3861,92 @@ ;; if prereq test with itempath=ref-item-path and COMPLETED with PASS, WARN, CHECK, or WAIVED then prereq is met ;; ;; Note: mode 'normal means that tests must be COMPLETED and ok (i.e. PASS, WARN, CHECK, SKIP or WAIVED) ;; mode 'toplevel means that tests must be COMPLETED only ;; mode 'itemmatch or 'itemwait means that tests items must be COMPLETED and (PASS|WARN|WAIVED|CHECK) [[ NB// NOT IMPLEMENTED YET ]] +;; mode 'exclusive means this test/item cannot run if the same test/item is LAUNCHED,REMOTEHOSTSTART or RUNNING ;; ;; (define (db:get-prereqs-not-met dbstruct run-id waitons ref-item-path mode) (define (db:get-prereqs-not-met dbstruct run-id waitons ref-test-name ref-item-path mode itemmaps) ;; #!key (mode '(normal))(itemmap #f)) - (if (or (not waitons) - (null? waitons)) - '() - (let* ((unmet-pre-reqs '()) - (result '())) - (for-each - (lambda (waitontest-name) - ;; by getting the tests with matching name we are looking only at the matching test - ;; and related sub items - ;; next should be using mt:get-tests-for-run? - (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) - (ever-seen #f) - (parent-waiton-met #f) - (item-waiton-met #f)) - (for-each - (lambda (test) - ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... - (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-running (equal? state "RUNNING")) - (is-killed (equal? state "KILLED")) - (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) - ;; testname-b path-a path-b - (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) - (set! ever-seen #t) - (cond - ;; case 1, non-item (parent test) is - ((and (equal? item-path "") ;; this is the parent test of the waiton being examined - is-completed - (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) - (set! parent-waiton-met #t)) - ;; Special case for toplevel and KILLED - ((and (equal? item-path "") ;; this is the parent test - is-killed - (member 'toplevel mode)) - (set! parent-waiton-met #t)) - ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met - ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? - ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items - same-itempath) - (if (and is-completed is-ok) - (set! item-waiton-met #t)) - (if (and (equal? item-path "") - (or is-completed is-running));; this is the parent, set it to run if completed or running - (set! parent-waiton-met #t))) - ;; normal checking of parent items, any parent or parent item not ok blocks running - ((and is-completed - (or is-ok - (member 'toplevel mode)) ;; toplevel does not block on FAIL - (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok - (set! item-waiton-met #t))))) - tests) - ;; both requirements, parent and item-waiton must be met to NOT add item to - ;; prereq's not met list - (if (not (or parent-waiton-met item-waiton-met)) - (set! result (append (if (null? tests) (list waitontest-name) tests) result))) - ;; if the test is not found then clearly the waiton is not met... - ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) - (if (not ever-seen) - (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) - waitons) - (delete-duplicates result)))) + (if (eq? mode 'exclusive) + (let ((running-tests (db:get-tests-for-run dbstruct + #f ;; run-id of #f means for all runs. + (if (string=? ref-item-path "") + ref-test-name + (conc ref-test-name "/" ref-item-path)) + '("LAUNCHED" "REMOTEHOSTSTART" "RUNNING") + '() + #f + #f + 'shortlist + 0 ;; last update, beginning of time .... + #f))) + running-tests) + (if (or (not waitons) + (null? waitons)) + '() + (let* ((unmet-pre-reqs '()) + (result '())) + (for-each + (lambda (waitontest-name) + ;; by getting the tests with matching name we are looking only at the matching test + ;; and related sub items + ;; next should be using mt:get-tests-for-run? + (let ((tests (db:get-tests-for-run-state-status dbstruct run-id waitontest-name)) + (ever-seen #f) + (parent-waiton-met #f) + (item-waiton-met #f)) + (for-each + (lambda (test) + ;; (if (equal? waitontest-name (db:test-get-testname test)) ;; by defintion this had better be true ... + (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-running (equal? state "RUNNING")) + (is-killed (equal? state "KILLED")) + (is-ok (member status '("PASS" "WARN" "CHECK" "WAIVED" "SKIP"))) + ;; testname-b path-a path-b + (same-itempath (db:compare-itempaths ref-test-name item-path ref-item-path itemmaps))) ;; (equal? ref-item-path item-path))) + (set! ever-seen #t) + (cond + ;; case 1, non-item (parent test) is + ((and (equal? item-path "") ;; this is the parent test of the waiton being examined + is-completed + (or is-ok (not (null? (lset-intersection eq? mode '(toplevel)))))) ;; itemmatch itemwait)))))) + (set! parent-waiton-met #t)) + ;; Special case for toplevel and KILLED + ((and (equal? item-path "") ;; this is the parent test + is-killed + (member 'toplevel mode)) + (set! parent-waiton-met #t)) + ;; For itemwait mode IFF the previous matching item is good the set parent-waiton-met + ((and (not (null? (lset-intersection eq? mode '(itemmatch itemwait)))) ;; how is that different from (member mode '(itemmatch itemwait)) ????? + ;; (not (equal? item-path "")) ;; this applies to both top level (to allow launching of next batch) and items + same-itempath) + (if (and is-completed is-ok) + (set! item-waiton-met #t)) + (if (and (equal? item-path "") + (or is-completed is-running));; this is the parent, set it to run if completed or running + (set! parent-waiton-met #t))) + ;; normal checking of parent items, any parent or parent item not ok blocks running + ((and is-completed + (or is-ok + (member 'toplevel mode)) ;; toplevel does not block on FAIL + (and is-ok (member 'itemmatch mode))) ;; itemmatch blocks on not ok + (set! item-waiton-met #t))))) + tests) + ;; both requirements, parent and item-waiton must be met to NOT add item to + ;; prereq's not met list + (if (not (or parent-waiton-met item-waiton-met)) + (set! result (append (if (null? tests) (list waitontest-name) tests) result))) + ;; if the test is not found then clearly the waiton is not met... + ;; (if (not ever-seen)(set! result (cons waitontest-name result))))) + (if (not ever-seen) + (set! result (append (if (null? tests)(list waitontest-name) tests) result))))) + waitons) + (delete-duplicates result))))) ;;====================================================================== ;; Just for sync, procedures to make sync easy ;;======================================================================