Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -198,24 +198,93 @@ SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state='COMPLETED' AND r.target LIKE ? GROUP BY r.target;" target-patt)) -(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt) + +(define (pgdb:get-latest-run-stats-given-target dbh ttype-id target-patt limit offset) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" - "SELECT r.target,COUNT(*) AS total, + "SELECT r.target, r.event_time, COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? and r.id in -(SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) GROUP BY r.target,r.id;" - ttype-id target-patt target-patt ttype-id)) + (SELECT DISTINCT on (target) id from runs where target like ? AND ttype_id=? order by target,event_time desc) + GROUP BY r.target,r.id + order by r.event_time desc limit ? offset ? ;" + ttype-id target-patt target-patt ttype-id limit offset)) + +(define (pgdb:get-latest-run-stats-given-pattern dbh patt limit offset) + (dbi:get-rows + dbh + ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target ILIKE ? GROUP BY r.target,t.status;" + "SELECT r.target, r.event_time, COUNT(*) AS total, + SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, + SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, + SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other, r.id + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE t.state like '%' AND r.target ILIKE ? + and r.id in + (SELECT DISTINCT on (target) id from runs where target ilike ? order by target,event_time desc) + GROUP BY r.target,r.id + order by r.event_time desc limit ? offset ? ;" + patt patt limit offset)) + + +(define (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt) + (dbi:get-rows + dbh + "SELECT count(*) from + (SELECT DISTINCT on (target) id + from runs where target like ? AND ttype_id = ? + order by target, event_time desc + ) as x;" + target-patt ttype-id)) + +(define (pgdb:get-latest-run-cnt dbh ttype-id target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-target-latest dbh ttype-id target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + +(define (pgdb:get-count-data-stats-latest-pattern dbh patt) + (dbi:get-rows + dbh + "SELECT count(*) from + (SELECT DISTINCT on (target) id + from runs where target ilike ? + order by target, event_time desc + ) as x;" + patt)) + +(define (pgdb:get-latest-run-cnt-by-pattern dbh target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-latest-pattern dbh target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + + + + (define (pgdb:get-run-stats-history-given-target dbh ttype-id target-patt) (dbi:get-rows dbh ;; "SELECT COUNT(t.id),t.status,r.target FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id @@ -227,31 +296,55 @@ FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE t.state like '%' AND ttype_id=? AND r.target LIKE ? GROUP BY r.run_name;" ttype-id target-patt )) -(define (pgdb:get-all-run-stats-target-slice dbh target-patt) -(dbi:get-rows - dbh - "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total, +(define (pgdb:get-all-run-stats-target-slice dbh target-patt limit offset) + (dbi:get-rows + dbh + "SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total, SUM(CASE WHEN t.status='PASS' THEN 1 ELSE 0 END) AS pass, SUM(CASE WHEN t.status='FAIL' THEN 1 ELSE 0 END) AS fail, SUM(CASE WHEN t.status IN ('PASS','FAIL') THEN 0 ELSE 1 END) AS other FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE r.target LIKE ? - - GROUP BY r.target,r.run_name, r.event_time;" + GROUP BY r.target,r.run_name, r.event_time + order by r.target,r.event_time desc limit ? offset ? ;" + target-patt limit offset)) + + +(define (pgdb:get-count-data-stats-target-slice dbh target-patt) + (dbi:get-rows + dbh + "SELECT count(*) from (SELECT r.target, r.run_name,r.event_time, COUNT(*) AS total + FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id + WHERE r.target LIKE ? + GROUP BY r.target,r.run_name, r.event_time + ) as x;" target-patt)) +(define (pgdb:get-slice-cnt dbh target-patt) + (let* ((cnt-result (pgdb:get-count-data-stats-target-slice dbh target-patt)) + ;(cnt-row (car (cnt-result))) + (cnt 0) + ) + (for-each + (lambda (row) + (set! cnt (vector-ref row 0 ))) + cnt-result) + +cnt)) + (define (pgdb:get-target-types dbh) (dbi:get-rows dbh "SELECT id,target_spec FROM ttype;")) (define (pgdb:get-distict-target-slice dbh) (dbi:get-rows dbh " select distinct on (split_part (target, '/', 1)) (split_part (target, '/', 1)) from runs;")) - + (define (pgdb:get-distict-target-slice3 dbh) + (dbi:get-rows dbh " select distinct on (split_part (target, '/', 3)) (split_part (target, '/', 3)) from runs;")) ;; (define (pgdb:get-targets dbh target-patt) (let ((ttypes (pgdb:get-target-types dbh))) (map (lambda (ttype-dat) @@ -287,18 +380,49 @@ ;; using row-or-col to choose row or column ;; ht{row key}=>ht{col key}=>data ;; ;; fnum is the field number in the tuples to be split ;; + +(define (pgdb:mk-pattern dot type bp rel) + (let* ((typ (if (equal? type "all") + "%" + type)) + (dotprocess (if (equal? dot "all") + "%" + dot)) + (rel-num (if (equal? rel "") + "%" + rel)) + (pattern (conc "%/" bp "/" dotprocess "/" typ "_" rel-num))) +pattern)) + (define (pgdb:coalesce-runs dbh runs all-parts row-or-col fnum) (let* ((data (make-hash-table))) - ;; (rnums ( - ;; for now just do first => remainder + (for-each (lambda (run) (let* ((target (vector-ref run fnum)) (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data first #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data first newht) + (set! coldat newht))) + (hash-table-set! coldat rest run))) + runs) + data)) + + +(define (pgdb:coalesce-runs1 runs ) + (let* ((data (make-hash-table))) + + (for-each + (lambda (run) + (let* ((target (vector-ref run 0)) + (parts (string-split target "/")) (first (car parts)) (rest (string-intersperse (cdr parts) "/")) (coldat (hash-table-ref/default data first #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data first newht) @@ -379,5 +503,15 @@ (lambda (run) (let* ((run-name (vector-ref run 0))) (hash-table-set! data run-name run))) runs) data)) + +(define (pgdb:get-pg-lst tab2-pages) + (let loop ((i 1) + (lst `())) + (cond + ((> i tab2-pages ) + lst) + (else + (loop (+ i 1) (append lst (list i))))))) + ADDED cgisetup/pages/filter-defs-template.scm Index: cgisetup/pages/filter-defs-template.scm ================================================================== --- /dev/null +++ cgisetup/pages/filter-defs-template.scm @@ -0,0 +1,3 @@ +(define *p* '("a" "b" "c")) +(define *k* '("all" "a")) +(define *d* '("all" 1 2 3 6 5 8 11 12)) Index: cgisetup/pages/home.scm ================================================================== --- cgisetup/pages/home.scm +++ cgisetup/pages/home.scm @@ -9,8 +9,9 @@ ;; PURPOSE. ;;====================================================================== (use regex) (load "models/pgdb.scm") +(include "pages/filter-defs.scm") (include "pages/home_ctrl.scm") (include "pages/home_view.scm") Index: cgisetup/pages/home_ctrl.scm ================================================================== --- cgisetup/pages/home_ctrl.scm +++ cgisetup/pages/home_ctrl.scm @@ -12,29 +12,19 @@ ;; a function -action is called on POST (define (home-action action) (case (string->symbol action) ((filter) - (let ((target-type (s:get-input 'target-type)) - (target-filter (s:get-input 'tfilter)) - (target (s:get-input 'target)) - (row-or-col (s:get-input 'row-or-col))) - ;; - ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. - ;; - (s:set! "row-or-col" (if (list? row-or-col) - (string-intersperse row-or-col ",") - row-or-col)) - (s:set! "target-type" target-type) - (s:set! "tfilter" target-filter) - (s:set! "target" target) - (s:set! "target-filter" target-filter))) -((filter2) - (let ((tslice-select (s:get-input 'tslice-select)) - (t-slice-filter (s:get-input 't-slice-filter))) - ;; - ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. - ;; - (s:set! "tslice" tslice-select) - (s:set! "t-slice-patt" t-slice-filter))) -)) + (let ((dot (s:get-input 'dot)) + (type (s:get-input 'kit-type)) + (rel (s:get-input 'rel-num)) + (bp (s:get-input 'bp))) + ;; + ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. + ;; + + (s:set! "dot" dot) + (s:set! "type" type) + (s:set! "bp" bp) + + (s:set! "rel" rel))))) Index: cgisetup/pages/home_view.scm ================================================================== --- cgisetup/pages/home_view.scm +++ cgisetup/pages/home_view.scm @@ -8,143 +8,100 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (define (pages:home session db shared) + (let* ((dbh (s:db)) - (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:get "target-type") "-1"))) - (target-slice (pgdb:get-distict-target-slice dbh)) - (selected-slice (or (s:get "tslice") "")) - (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) - (curr-ttype (if (and selected - (not (null? curr-trec))) - (vector-ref (car curr-trec) 1) #f)) - (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) - (tfilter (or (s:get "target-filter") "%")) - (tslice-filter (or (s:get "t-slice-patt") "")) - (target-patt (if (or (equal? selected-slice "") (equal? tslice-filter "" )) - "" - (conc selected-slice "/" tslice-filter ))) - (tab2-data (if (equal? target-patt "") - `() - (pgdb:get-all-run-stats-target-slice dbh target-patt))) - (tab2-ordered-data (pgdb:coalesce-runs-by-slice tab2-data selected-slice)) - (targets (pgdb:get-targets-of-type dbh selected tfilter)) - (row-or-col (string-split (or (s:get "row-or-col") "") ",")) - (all-data (if (and selected - (not (eq? selected -1))) - (pgdb:get-latest-run-stats-given-target dbh selected tfilter) - '() + (limit 50) + (curr-page (if (or (equal? (s:get-param "pg") "") (equal? (s:get-param "pg") #f)) + 1 + (string->number (s:get-param "pg")))) + + (offset (- (* limit curr-page) limit)) + (dot (if (s:get-param "dot") + (string->number (s:get-param "dot")) + (if (and (s:get "dot") (not (equal? (s:get "dot") "all"))) + (string->number (s:get "dot")) + "all"))) + (type (if (s:get-param "type") + (s:get-param "type") + (if (and (s:get "type") (not (equal? (s:get "type") "all"))) + (s:get "type") + "all"))) + (bp (if (s:get-param "bp") + (s:get-param "bp") + (if (s:get "bp") + (s:get "bp") + "p1273"))) + (rel (if (s:get-param "rel") + (s:get-param "rel") + (if (and (s:get "rel") (not (equal? (s:get "rel") "all"))) + (s:get "rel") + ""))) + (pattern (pgdb:mk-pattern dot type bp rel)) + ; (targets (pgdb:get-targets-of-type dbh selected tfilter)) + + (all-data (pgdb:get-latest-run-stats-given-pattern dbh pattern limit offset)) + ;'() ) ; (pgdb:get-stats-given-type-target dbh selected tfilter) ; (pgdb:get-stats-given-target dbh tfilter) - )) - (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) + + (cnt (pgdb:get-latest-run-cnt-by-pattern dbh pattern)) + (total-pages (ceiling (/ cnt limit))) + (page-lst (pgdb:get-pg-lst total-pages)) + (ordered-data (pgdb:coalesce-runs1 all-data)) + (rel-val (if (equal? rel "") + "%" + rel))) (s:div 'class "col_12" (s:ul 'class "tabs left" - (s:li (s:a 'href "#tabr1" "Sliced Filter")) - (s:li (s:a 'href "#tabr2" "Genral Filter"))) - (s:div 'id "tabr1" 'class "tab-content" - (s:div 'class "col_11" - (s:fieldset "Filter Targets by slice" - (s:form - 'action "home.filter2" 'method "post" - (s:div 'class "col_12" - (s:div 'class "col_6" - (s:select (map (lambda (x) - (let ((t-slice (vector-ref x 0))) - (if (equal? t-slice selected-slice) - (list t-slice t-slice t-slice #t) - (list t-slice t-slice t-slice #f)))) - target-slice) - 'name 'tslice-select)) - (s:div 'class "col_4" - (s:input-preserve 'name "t-slice-filter" 'placeholder "Filter remainder target")) - (s:div 'class "col_2" - (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))))) - (s:br) - (s:p "  Result Format:   total / pass / fail / other") - (s:fieldset (conc "Runs data for " target-patt) - (let* ((target-keys (hash-table-keys tab2-ordered-data)) - (run-keys (delete-duplicates (apply append (map (lambda (sub-key) - (let ((subdat (hash-table-ref tab2-ordered-data sub-key))) - (hash-table-keys subdat))) - target-keys))))) - (s:table 'class "striped" - (s:tr (s:th 'class "heading" ) - (map - (lambda (th-key) - (s:th 'class "heading" th-key )) - run-keys)) - (map - (lambda (row-key) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (let ((val (let* ((ht (hash-table-ref/default tab2-ordered-data row-key #f))) - (if ht (hash-table-ref/default ht col-key #f))))) - (if val - (let* ((total (vector-ref val 3)) - (pass (vector-ref val 4)) - (fail (vector-ref val 5)) - (other (vector-ref val 6)) - (passper (round (* (/ pass total) 100))) - (target-param (string-substitute "[/]" "_x_" (conc selected-slice "/" row-key) 'all))) - (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") - (s:a 'class "white" 'href (s:link-to "run" 'target target-param 'run col-key) -(conc total "/" pass "/" fail "/" other)))) - (s:td "")))) - run-keys))) - target-keys)) -)) -)) - (s:div 'id "tabr2" 'class "tab-content" + + (map (lambda (x) + (s:li (s:a 'href (conc "#" x) x))) + *process*)) + (map (lambda (x) + + (s:div 'id x 'class "tab-content" (s:div 'class "col_11" (s:fieldset "Area type and target filter" (s:form - 'action "home.filter#tabr2" 'method "post" + 'action (conc "home.filter#" x) 'method "post" (s:div 'class "col_12" - (s:div 'class "col_6" - (s:select (map (lambda (x) - (if x - (let ((tt-id (vector-ref x 0)) - (ttype (vector-ref x 1))) - (if (eq? tt-id selected) - (list ttype tt-id ttype #t) - (list ttype tt-id ttype #f))) - (list "all" -1 "all" (eq? selected -1)))) - (cons #f ttypes)) - 'name 'target-type)) - (s:div 'class "col_4" - (s:input-preserve 'name "tfilter" 'placeholder "Filter targets")) + (s:div 'class "col_3" + (s:label "Release Type") (s:select (map (lambda (x) + (if (equal? x type) + (list x x x #t) + (list x x x #f)) ) + *kit-types*) + 'name "kit-type")) + (s:div 'class "col_3" + (s:label "Dot") (s:select (map (lambda (x) + (if (equal? x dot) + (list x x x #t) + (list x x x #f))) + *dots*) + 'name "dot")) + + (s:div 'class "col_3" + (s:input 'type "hidden" 'value x 'name "bp") + (s:label "Release #") (s:input 'type "text" 'name "rel-num" 'value rel-val)) (s:div 'class "col_2" (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))))) - (s:br) + (s:br) + ;(s:p (conc dot(string? dot) )) + (s:p (map + (lambda (i) + (s:span (s:a 'href (s:link-to "home" 'pg i ) "PAGE " i )" | ")) + page-lst)) (s:p "  Result Format:   total / pass / fail / other") - (s:fieldset (conc "Runs data for " tfilter) - ;; - ;; A very basic display - ;; - (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data)) + (if (equal? x bp) + (begin + (s:fieldset (conc "Runs data for " pattern) + (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data)) (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys))) - ;; (c-keys (delete-duplicates b-keys))) - (if #f ;; swap rows/cols - (s:table - (s:tr (s:td "")(map s:tr b-keys)) - (map - (lambda (row-key) - (let ((subdat (hash-table-ref ordered-data row-key))) - (s:tr (s:td row-key) - (map - (lambda (col-key) - (s:td (let ((dat (hash-table-ref/default subdat col-key #f))) - (s:td (if dat - (list (vector-ref dat 0)(vector-ref dat 1)) - ""))))) - b-keys)))) - a-keys)) - (s:table 'class "striped" + (s:table 'class "striped" (s:tr (s:th 'class "heading" ) (map (lambda (th-key) (s:th 'class "heading" th-key )) a-keys)) @@ -154,24 +111,25 @@ (map (lambda (col-key) (let ((val (let* ((ht (hash-table-ref/default ordered-data col-key #f))) (if ht (hash-table-ref/default ht row-key #f))))) (if val - (let* ((total (vector-ref val 1)) - (pass (vector-ref val 2)) - (fail (vector-ref val 3)) - (other (vector-ref val 4)) - (id (vector-ref val 5)) + (let* ((total (vector-ref val 2)) + (event-time (vector-ref val 1)) + (pass (vector-ref val 3)) + (fail (vector-ref val 4)) + (other (vector-ref val 5)) + (id (vector-ref val 6)) (passper (round (* (/ pass total) 100))) (failper (- 100 passper)) - (history (pgdb:get-run-stats-history-given-target dbh selected (conc col-key "/" row-key))) + (history (pgdb:get-run-stats-history-given-target dbh 1 (conc col-key "/" row-key))) (history-hash (pgdb:get-history-hash history)) (history-keys (sort (hash-table-keys history-hash) string>=?)) (run-key (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all))) (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") (s:a 'class "white" 'href (s:link-to "run" 'target run-key) - (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span " | ") (s:a 'id id 'class "viewmodal" 'title "Click to see description" "History") (s:br) + (conc "Latest:" total "/" pass "/" fail "/" other)) (s:span " | ") (s:a 'id id 'class "viewmodal" 'title "Click to see description" "History") (s:br) (s:div 'id (conc "myModal" id) 'class "modal" (s:div 'class "modal-content" (s:span 'id id 'class "close" "×") ;(s:p (conc "Modal " id "..")) (s:div @@ -189,13 +147,13 @@ (hother (vector-ref history-row 4)) (passper (round (* (/ hpass htotal) 100)))) (s:tr (s:td history-key) (s:td 'style (conc "background: -webkit-linear-gradient(left, green " passper "%, red); background: -o-linear-gradient(right, green " passper "%, red); background: -moz-linear-gradient(right, green " passper "%, red); background: linear-gradient(to right, green " passper "%, red);") (conc htotal "/" hpass "/" hfail "/" hother ))))) - history-keys))) - -)) - )) + history-keys))))))) (s:td "")))) a-keys))) - b-keys))))))) -))) + b-keys)))) +) +(begin +(s:p "")))))) + *process*)))) Index: cgisetup/pages/index.scm ================================================================== --- cgisetup/pages/index.scm +++ cgisetup/pages/index.scm @@ -8,9 +8,10 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use regex) + ;; (load "models/pgdb.scm") -(include "pages/index_ctrl.scm") -(include "pages/index_view.scm") +(include "pages/index_ctrl.scm") +(include "pages/index_view.scm") Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -62,11 +62,11 @@ EOF )) (define index:javascript #< + EOF ) Index: cgisetup/pages/index_view.scm ================================================================== --- cgisetup/pages/index_view.scm +++ cgisetup/pages/index_view.scm @@ -22,10 +22,17 @@ index:kickstart-junk ) (s:body (s:div 'class "grid flex" 'id "top_of_page" ;; add visible to columns to help visualize them e.g. "col_12 visible" + (s:ul 'class "menu" +(s:li (s:a 'href "" (s:i 'class "fa fa-inbox") "QA Summary") + (s:ul + (s:li (s:a 'href "/cgi-bin/megatest.sh/home" "Component Snapshot")) + (s:li (s:a 'href "/cgi-bin/megatest.sh/kitprogress" "Kit/Contour progress")) + ))) +;(s:li (s:a 'href (s:link-to "run" ) "Runs"))) (case (string->symbol page-name) ((index) (s:call "home")) (else (s:call page-name)))) index:jquery index:javascript Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1030,13 +1030,17 @@ (let ((res (or (args:get-arg "-runname") (args:get-arg ":runname") (getenv "MT_RUNNAME")))) ;; (if res (set-environment-variable "MT_RUNNAME" res)) ;; not sure if this is a good idea. side effect and all ... res)) + +(define (common:get-fields cfgdat) + (let ((fields (hash-table-ref/default cfgdat "fields" '()))) + (map car fields))) (define (common:args-get-target #!key (split #f)(exit-if-bad #f)) - (let* ((keys (if (hash-table? *configdat*) (keys:config-get-fields *configdat*) '())) + (let* ((keys (if (hash-table? *configdat*) (common:get-fields *configdat*) '())) (numkeys (length keys)) (target (or (args:get-arg "-reqtarg") (args:get-arg "-target") (getenv "MT_TARGET"))) (tlist (if target (string-split target "/" #t) '())) Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -15,10 +15,11 @@ (use regex regex-case) ;; directory-utils) (declare (unit configf)) (declare (uses process)) (declare (uses env)) +(declare (uses keys)) (include "common_records.scm") ;; return list (path fullpath configname) (define (find-config configname #!key (toppath #f)) @@ -400,11 +401,11 @@ (let* ((curr-dir (current-directory)) (configinfo (find-config fname toppath: given-toppath)) (toppath (car configinfo)) (configfile (cadr configinfo)) (set-fields (lambda (curr-section next-section ht path) - (let ((field-names (if ht (keys:config-get-fields ht) '())) + (let ((field-names (if ht (common:get-fields ht) '())) (target (or (getenv "MT_TARGET")(args:get-arg "-reqtarg")(args:get-arg "-target")))) (debug:print-info 9 *default-log-port* "set-fields with field-names=" field-names " target=" target " curr-section=" curr-section " next-section=" next-section " path=" path " ht=" ht) (if (not (null? field-names))(keys:target-set-args field-names target #f)))))) (if toppath (change-directory toppath)) (if (and toppath pathenvvar)(setenv pathenvvar toppath)) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -64,9 +64,6 @@ ;;====================================================================== ;; config file related routines ;;====================================================================== -(define (keys:config-get-fields confdat) - (let ((fields (hash-table-ref/default confdat "fields" '()))) - (map car fields))) - +(define keys:config-get-fields common:get-fields) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -12,11 +12,11 @@ ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) (use srfi-1 posix srfi-69 readline ;; regex regex-case srfi-69 apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - srfi-18 extras format pkts pkts regex regex-case + srfi-18 extras format pkts regex regex-case (prefix dbi dbi:)) ;; zmq extras) (declare (uses common)) (declare (uses megatest-version)) (declare (uses margs)) @@ -56,55 +56,56 @@ mtutil, part of the Megatest tool suite, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright Matt Welland 2006-2017 Usage: mtutil action [options] - -h : this help - -manual : show the Megatest user manual - -version : print megatest version (currently " megatest-version ") - -Actions: - run : initiate runs - remove : remove runs - rerun : register action for processing - set-ss : set state/status - archive : compress and move test data to archive disk - kill : stop tests or entire runs - db : database utilities + -h : this help + -manual : show the Megatest user manual + -version : print megatest version (currently " megatest-version ") + +Actions: + run : initiate runs + remove : remove runs + rerun : register action for processing + set-ss : set state/status + archive : compress and move test data to archive disk + kill : stop tests or entire runs + db : database utilities + areas, contours, setup : show areas, contours or setup section from megatest.config Contour actions: - process : runs import, rungen and dispatch - -Selectors - -immediate : apply this action immediately, default is to queue up actions - -area areapatt1,area2... : apply this action only to the specified areas - -target key1/key2/... : run for key1, key2, etc. - -test-patt p1/p2,p3/... : % is wildcard - -run-name : required, name for this particular test run - -contour contourname : run all targets for contourname, requires -run-name, -target - -state-status c/p,c/f : Specify a list of state and status patterns - -tag-expr tag1,tag2%,.. : select tests with tags matching expression - -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT - if -testpatt and -tagexpr are not specified - -new state/status : specify new state/status for set-ss - -Misc - -start-dir path : switch to this directory before running mtutil - -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are - overwritten by values set in config files. - -log logfile : send stdout and stderr to logfile - -repl : start a repl (useful for extending megatest) - -load file.scm : load and run file.scm - -debug N|N,M,O... : enable debug messages 0-N or N and M and O ... - -Utility - db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\" + process : runs import, rungen and dispatch + +Selectors + -immediate : apply this action immediately, default is to queue up actions + -area areapatt1,area2... : apply this action only to the specified areas + -target key1/key2/... : run for key1, key2, etc. + -test-patt p1/p2,p3/... : % is wildcard + -run-name : required, name for this particular test run + -contour contourname : run all targets for contourname, requires -run-name, -target + -state-status c/p,c/f : Specify a list of state and status patterns + -tag-expr tag1,tag2%,.. : select tests with tags matching expression + -mode-patt key : load testpatt from in runconfigs instead of default TESTPATT + if -testpatt and -tagexpr are not specified + -new state/status : specify new state/status for set-ss + +Misc + -start-dir path : switch to this directory before running mtutil + -set-vars V1=1,V2=2 : Add environment variables to a run NB// these are + overwritten by values set in config files. + -log logfile : send stdout and stderr to logfile + -repl : start a repl (useful for extending megatest) + -load file.scm : load and run file.scm + -debug N|N,M,O... : enable debug messages 0-N or N and M and O ... + +Utility + db pgschema : emit postgresql schema; do \"mtutil db pgschema | psql -d mydb\" Examples: # Start a megatest run in the area \"mytests\" -mtutil -area mytests -action run -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick +mtutil run -area mytests -target v1.63/aa3e -mode-patt MYPATT -tag-expr quick # Start a contour mtutil run -contour quick -target v1.63/aa3e Called as " (string-intersperse (argv) " ") " @@ -111,41 +112,44 @@ Version " megatest-version ", built from " megatest-fossil-hash )) ;; args and pkt key specs ;; (define *arg-keys* - '(("-area" . G) ;; maps to group - ("-target" . t) - ("-run-name" . n) - ("-state" . e) - ("-status" . s) - ("-contour" . c) - ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" - ("-mode-patt" . o) - ("-tag-expr" . x) - ("-item-patt" . i) - ("-sync-to" . k) - ("-append-config" . d) + '( + ("-area" . G) ;; maps to group + ("-contour" . c) + ("-append-config" . d) + ("-state" . e) + ("-item-patt" . i) + ("-sync-to" . k) + ("-run-name" . n) + ("-mode-patt" . o) + ("-test-patt" . p) ;; idea, enhance margs ("-test-patt" "-testpatt") => yields one value in "-test-patt" + ("-status" . s) + ("-target" . t) + ("-tag-expr" . x) ;; misc - ("-start-dir" . S) - ("-msg" . M) - ("-set-vars" . v) - ("-debug" . #f) ;; for *verbosity* > 2 - ("-load" . #f) ;; load and exectute a scheme file - ("-log" . #f) + ("-debug" . #f) ;; for *verbosity* > 2 + ("-load" . #f) ;; load and exectute a scheme file + ("-log" . #f) + ("-msg" . M) + ("-start-dir" . S) + ("-set-vars" . v) )) (define *switch-keys* - '(("-h" . #f) - ("-help" . #f) - ("--help" . #f) - ("-manual" . #f) - ("-version" . #f) - ;; misc - ("-repl" . #f) - ("-immediate" . I) - ("-preclean" . r) - ("-rerun-all" . u) + '( + ("-h" . #f) + ("-help" . #f) + ("--help" . #f) + ("-manual" . #f) + ("-version" . #f) + ;; misc + ("-repl" . #f) + ("-immediate" . I) + ("-preclean" . r) + ("-rerun-all" . u) + ("-prepend-contour" . w) )) ;; alist to map actions to old megatest commands (define *action-keys* '((run . "-run") @@ -298,10 +302,11 @@ (not (or (args:get-arg "-runstep") (args:get-arg "-envcap") (args:get-arg "-envdelta") (member *action* '("db")) ;; very loose checks on db. + (equal? *action* "show") ;; just keep going if list ))) (debug:print-error 0 *default-log-port* "Unrecognised arguments: " (string-intersperse (if (list? remargs) remargs (argv)) " "))) (if (or (args:any? "-h" "help" "-help" "--help") (member *action* '("-h" "-help" "--help" "help"))) @@ -321,13 +326,15 @@ (if (not (and pktsdir toppath pdbpath)) (begin (print "ERROR: settings are missing in your megatest.config for area management.") (print " you need to have pktsdir in the [setup] section.")) (let* ((pdb (open-queue-db pdbpath "pkts.db" - schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));")))) - (proc pktsdirs pktsdir pdb) - (dbi:close pdb))))) + schema: '("CREATE TABLE groups (id INTEGER PRIMARY KEY,groupname TEXT, CONSTRAINT group_constraint UNIQUE (groupname));"))) + (res (proc pktsdirs pktsdir pdb))) + (dbi:close pdb) + res + )))) (define (load-pkts-to-db mtconf) (with-queue-db mtconf (lambda (pktsdirs pktsdir pdb) @@ -344,12 +351,13 @@ (if (not exists) (let* ((pktdat (string-intersperse (with-input-from-file pkt read-lines) "\n")) (apkt (pkt->alist pktdat)) - (ptype (alist-ref 'T apkt))) - (add-to-queue pdb pktdat uuid (or ptype 'cmd) #f 0) + (ptype (alist-ref 'T apkt)) + (parent (alist-ref 'P apkt))) + (add-to-queue pdb pktdat uuid (or ptype 'cmd) parent 0) (debug:print 4 *default-log-port* "Added " uuid " of type " ptype " to queue")) (debug:print 4 *default-log-port* "pkt: " uuid " exists, skipping...") ))) pkts)))) (string-split pktsdirs))))) @@ -486,20 +494,25 @@ ((hash-table-ref *target-mappers* xlatr-key) runkey new-runname area area-path reason contour mode-patt))) (begin (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.") runkey))) - runkey))) + runkey)) + (actual-action (if action + (if (equal? action "sync-prepend") + "sync" + action) + "run"))) ;; this has gotten a bit ugly. Need a function to handle actions processing. ;; some hacks to remove switches not needed in certain cases (case (string->symbol (or action "run")) - ((sync) + ((sync sync-prepend) (set! new-target #f) (set! runame #f))) (print "area-path: " area-path " area-xlatr: " area-xlatr " orig-target: " runkey " new-target: " new-target) (let-values (((uuid pkt) (command-line->pkt - (if action action "run") + actual-action (append `(("-start-dir" . ,area-path) ("-msg" . ,reason) ("-contour" . ,contour)) (if (good-val new-runname) `(("-run-name" . ,new-runname)) '()) @@ -506,10 +519,11 @@ (if (good-val new-target) `(("-target" . ,new-target)) '()) (if (good-val mode-patt) `(("-mode-patt" . ,mode-patt)) '()) (if (good-val tag-expr) `(("-tag-expr" . ,tag-expr)) '()) (if (good-val dbdest) `(("-sync-to" . ,dbdest)) '()) (if (good-val append-conf) `(("-append-config" . ,append-conf)) '()) + (if (equal? action "sync-prepend") '(("-prepend-contour" . " ")) '()) (if (not (or mode-patt tag-expr)) `(("-testpatt" . "%")) '()) (if (or (not action) (equal? action "run")) @@ -613,11 +627,11 @@ (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X")) (runname std-runname)) ;; (conc "sched" (time->string (seconds->local-time (current-seconds)) "%M%H%d"))))) ;; (print "last-run: " last-run " need-run: " need-run) ;; (if need-run (case (string->symbol action) - ((sync) + ((sync sync-prepend) (if (common:extended-cron crontab #f last-sync) (push-run-spec torun contour runkey `((message . ,(conc ruletype ":sync-" cron-safe-string)) (action . ,action) (dbdest . ,(alist-ref 'dbdest val-alist)) @@ -808,11 +822,11 @@ (target (or (alist-ref 'target runkeydat) runkey))) ;; override with target if forced (print "Have: runkey=" runkey " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt " target=" target) (if (case (or (and action (string->symbol action)) 'noaction) ;; ensure we have the needed data to run this action ((noaction) #f) ((run) (and runname reason)) - ((sync) (and reason dbdest)) + ((sync sync-prepend) (and reason dbdest)) (else #f)) ;; instead of unwrapping the runkeydat alist, pass it directly to create-run-pkt (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append runtrans) (print "ERROR: Missing info to make a " action " call: runkey=" runkey " contour=" contour " area=" area " tag-expr=" tag-expr " mode-patt=" mode-patt " dbdest=" dbdest) )) @@ -910,11 +924,11 @@ (if (file-exists? debugcontrolf) (load debugcontrolf))) (if *action* (case (string->symbol *action*) - ((run remove rerun set-ss archive kill) + ((run remove rerun set-ss archive kill list) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) (adjargs (hash-table-copy args:arg-hash))) @@ -937,10 +951,32 @@ (load-pkts-to-db mtconf) (dispatch-commands mtconf toppath))) ((import) (load-pkts-to-db mtconf)) ;; import pkts ((rungen) (generate-run-pkts mtconf toppath)) ((dispatch) (dispatch-commands mtconf toppath))))) + ;; misc + ((show) + (if (> (length remargs) 0) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat)) + (sect-dat (configf:get-section mtconf (car remargs)))) + (if sect-dat + (for-each + (lambda (entry) + (if (> (length entry) 1) + (print (car entry) " " (cadr entry)) + (print (car entry)))) + sect-dat) + (print "No section \"" (car remargs) "\" found"))) + (print "ERROR: list requires section parameter; areas, setup or contours"))) + ((gendot) + (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) + (mtconf (car mtconfdat))) + (with-queue-db + mtconf + (lambda (pktsdirs pktsdir conn) + (make-report "out.dot" conn '()))))) ((db) (if (null? remargs) (print "ERROR: missing sub command for db command") (let ((subcmd (car remargs))) (case (string->symbol subcmd) @@ -977,5 +1013,11 @@ (install-history-file (get-environment-variable "HOME") ".mtutil_history") ;; [homedir] [filename] [nlines]) (current-input-port (make-readline-port "mtutil> ")) (if (args:get-arg "-repl") (repl) (load (args:get-arg "-load"))))) + +#| +(define mtconf (car (simple-setup #f))) +(define dat (with-queue-db mtconf (lambda (conn)(get-pkts conn '())))) +(pp (pkts#flatten-all dat '((cmd . ((parent . P)(url . M)))(runtype . ((parent . P)))) 'id 'group-id 'uuid 'parent 'pkt-type 'pkt 'processed)) +|# Index: runconfigs.config ================================================================== --- runconfigs.config +++ runconfigs.config @@ -7,12 +7,13 @@ # # example of a cron entry to run sync using db spec pgdb, with pgdb setting in file local.config # [a/b/c] -all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config -quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config +all:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config +# quick:scheduled:sync cron= 0/5 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config +# fast:scheduled:sync-prepend cron= 0/1 * * * *;dbdest=pgdb;appendconf=/mfs/matt/.sysmaint/local.config [scriptinc ./gentargets.sh #{getenv USER}] # [v1.23/45/67] # tip will be replaced with hashkey? @@ -24,24 +25,25 @@ # [v1.63/tip/dev] # file: files changes since last run trigger new run # script: script is called with unix seconds as last parameter (other parameters are preserved) # # contour:sensetype:action params data -quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm -snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm +# commented out for debug +# quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm +# snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm # script returns change-time (unix epoch), new-target-name, run-name # # quick:script:run checkfossil = http://www.kiatoa.com/fossils/megatest v1.63;\ # checkfossil = http://www.kiatoa.com/fossils/megatest_qa trunk -# fossil based trigger -# -quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\ - http://www.kiatoa.com/fossils/megatest_qa=trunk;\ - http://www.kiatoa.com/fossils/megatest=v1.64 +# # fossil based trigger +# # +# quick:fossil:run http://www.kiatoa.com/fossils/megatest=v1.63;\ +# http://www.kiatoa.com/fossils/megatest_qa=trunk;\ +# http://www.kiatoa.com/fossils/megatest=v1.64 # field allowed values # ----- -------------- # minute 0-59 # hour 0-23 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -1238,11 +1238,11 @@ (tconfig (tests:testqueue-get-testconfig test-record)) (jobgroup (config-lookup tconfig "test_meta" "jobgroup")) (testmode (let ((m (config-lookup tconfig "requirements" "mode"))) (if m (map string->symbol (string-split m)) '(normal)))) (itemmaps (tests:get-itemmaps tconfig)) ;; (configf:lookup tconfig "requirements" "itemmap")) - (waitons (tests:testqueue-get-waitons test-record)) + (waitons (tests:just-get-waitons test-name test-records)) ;; (tests:testqueue-get-waitons test-record)) (priority (tests:testqueue-get-priority test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) ;; itemdat can be a string, list or #f (items (tests:testqueue-get-items test-record)) (item-path (item-list->path itemdat)) (tfullname (db:test-make-full-name test-name item-path)) @@ -1510,11 +1510,11 @@ ;; 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 these vars might be referenced by the testconfig file reader (let* ((test-name (tests:testqueue-get-testname test-record)) - (test-waitons (tests:testqueue-get-waitons test-record)) + (test-waitons (tests:just-get-waitons test-name all-tests-registry)) ;; (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)) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -142,20 +142,35 @@ (debug:print-info 4 *default-log-port* "items and itemstable are lists, calc now\n" " items: " items " itemstable: " itemstable) (items:get-items-from-config tconfig)) (else #f)))) ;; not iterated - ;; returns waitons waitors tconfigdat ;; -(define (tests:get-waitons test-name all-tests-registry) - (let* ((config (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) +;; firm-require forces that the test be referred to in all-tests-registry +;; +(define (tests:get-waitons test-name all-tests-registry #!key (in-tconfig #f)(firm-require #t)) + (let* ((config (or in-tconfig (tests:get-testconfig test-name #f all-tests-registry 'return-procs))) + (extras (configf:get-section *configdat* "waitons")) + (ewaits (if extras (alist-ref test-name extras string=?) #f)) + (ewlst (if (and ewaits (not (null? ewaits))) + (string-split (car ewaits)) + '())) + (ewadd (if (null? ewlst) + #t + (equal? (car ewlst) "+"))) ;; signal for add + (ewaitlst (if (null? ewlst) + ewlst + (if ewadd + (cdr ewlst) + ewlst)))) (let ((instr (if config (config-lookup config "requirements" "waiton") - (begin ;; No config means this is a non-existant test + (if firm-require ;; begin ;; No config means this is a non-existant test (debug:print-error 0 *default-log-port* "non-existent required test \"" test-name "\"") - (exit 1)))) + ;; (exit 1) + ))) (instr2 (if config (config-lookup config "requirements" "waitor") ""))) (debug:print-info 8 *default-log-port* "waitons string is " instr ", waitors string is " instr2) (let ((newwaitons @@ -179,24 +194,35 @@ ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " test-name) ""))))) (values ;; the waitons (filter (lambda (x) - (if (hash-table-ref/default all-tests-registry x #f) + (if (or (not firm-require) + (hash-table-ref/default all-tests-registry x #f)) #t (begin (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) #f))) - newwaitons) + (if ewadd ;; area we adding or replacing the waitons + (append newwaitons ewaitlst) + ewaitlst)) (filter (lambda (x) - (if (hash-table-ref/default all-tests-registry x #f) + (if (or (not firm-require) + (hash-table-ref/default all-tests-registry x #f)) #t (begin - (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waiton testname " x) + (debug:print-error 0 *default-log-port* "test " test-name " has unrecognised waitor testname " x) #f))) newwaitors) config))))) + +;; seems like often we just want the waitons. Maybe time to get rid of the waitors concept? +;; +(define (tests:just-get-waitons test-name tests-registry #!key (in-tconfig #f)(firm-require #t)) + (let-values (((waitons waitors tconfig) + (tests:get-waitons test-name tests-registry in-tconfig: in-tconfig firm-require: firm-require))) + waitons)) ;; given waiting-test that is waiting on waiton-test extend test-patt appropriately ;; ;; genlib/testconfig sim/testconfig ;; genlib/sch sim/sch/cell1 @@ -1220,21 +1246,21 @@ 0))) (all-tests (hash-table-keys test-records)) (all-waited-on (let loop ((hed (car all-tests)) (tal (cdr all-tests)) (res '())) - (let* ((trec (hash-table-ref test-records hed)) - (waitons (or (tests:testqueue-get-waitons trec) '()))) - (if (null? tal) + (let* (;; (trec (hash-table-ref test-records hed)) + (waitons (tests:just-get-waitons hed test-records firm-require: #f))) ;; (or (tests:testqueue-get-waitons trec) '()))) + (if (null? tal) (append res waitons) (loop (car tal)(cdr tal)(append res waitons)))))) (sort-fn1 (lambda (a b) (let* ((a-record (hash-table-ref test-records a)) (b-record (hash-table-ref test-records b)) - (a-waitons (or (tests:testqueue-get-waitons a-record) '())) - (b-waitons (or (tests:testqueue-get-waitons b-record) '())) + (a-waitons (tests:just-get-waitons a test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons a-record) '())) + (b-waitons (tests:just-get-waitons b test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons b-record) '())) (a-config (tests:testqueue-get-testconfig a-record)) (b-config (tests:testqueue-get-testconfig b-record)) (a-raw-pri (config-lookup a-config "requirements" "priority")) (b-raw-pri (config-lookup b-config "requirements" "priority")) (a-priority (mungepriority a-raw-pri)) @@ -1290,12 +1316,12 @@ (format temp-port "digraph tests {\n") (format temp-port " size=4,8\n") ;; (format temp-port " splines=none\n") (for-each (lambda (testname) - (let* ((testrec (hash-table-ref test-records testname)) - (waitons (or (tests:testqueue-get-waitons testrec) '()))) + (let* (;; (testrec (hash-table-ref test-records testname)) + (waitons (tests:just-get-waitons testname test-records firm-require: #f))) ;; (or (tests:testqueue-get-waitons testrec) '()))) (for-each (lambda (waiton) (format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n"))) waitons))) all-testnames) @@ -1322,12 +1348,12 @@ (tal (cdr all-testnames)) (res (list "digraph tests {" (conc " size=\"" (or sizex 11) "," (or sizey 11) "\";") " ratio=0.95;" ))) - (let* ((testrec (hash-table-ref test-records hed)) - (waitons (or (tests:testqueue-get-waitons testrec) '())) + (let* (;; (testrec (hash-table-ref test-records hed)) + (waitons (tests:just-get-waitons hed test-records firm-require: #f)) ;; (or (tests:testqueue-get-waitons testrec) '())) (newres (append res (if (null? waitons) (list (conc " \"" hed "\" [shape=box];")) (map (lambda (waiton) (conc " \"" waiton "\" -> \"" hed "\" [shape=box];")) @@ -1380,11 +1406,11 @@ (lambda (testkeyname) (let* ((test-record (hash-table-ref testrecordshash testkeyname)) (test-name (tests:testqueue-get-testname test-record)) (itemdat (tests:testqueue-get-itemdat test-record)) (item-path (tests:testqueue-get-item_path test-record)) - (waitons (tests:testqueue-get-waitons test-record)) + (waitons (tests:just-get-waitons test-name testrecordshash)) ;; (tests:testqueue-get-waitons test-record)) (keep-test #t) (test-id (rmt:get-test-id run-id test-name item-path)) (tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id))) (if tdat (begin @@ -1427,25 +1453,28 @@ (let loop ((hed (car test-names)) (tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc (debug:print-info 4 *default-log-port* "hed=" hed " at top of loop") ;; don't know item-path at this time, let the testconfig get the top level testconfig (let* ((config (tests:get-testconfig hed #f all-tests-registry 'return-procs)) - (waitons (let ((instr (if config - (config-lookup config "requirements" "waiton") - (begin ;; No config means this is a non-existant test - (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") - "")))) - (debug:print-info 8 *default-log-port* "waitons string is " instr) - (string-split (cond - ((procedure? instr) - (let ((res (instr))) - (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) - res)) - ((string? instr) instr) - (else - ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " hed) - "")))))) + (waitons (let-values (((waitons waitors tconfigdat) + (tests:get-waitons hed all-tests-registry))) + waitons))) + ;; (let ((instr (if config + ;; (config-lookup config "requirements" "waiton") + ;; (begin ;; No config means this is a non-existant test + ;; (debug:print-error 0 *default-log-port* "non-existent required test \"" hed "\", grep through your testconfigs to find and remove or create the test. Discarding and continuing.") + ;; "")))) + ;; (debug:print-info 8 *default-log-port* "waitons string is " instr) + ;; (string-split (cond + ;; ((procedure? instr) + ;; (let ((res (instr))) + ;; (debug:print-info 8 *default-log-port* "waiton procedure results in string " res " for test " hed) + ;; res)) + ;; ((string? instr) instr) + ;; (else + ;; ;; NOTE: This is actually the case of *no* waitons! ;; (debug:print-error 0 *default-log-port* "something went wrong in processing waitons for test " hed) + ;; "")))))) (if (not config) ;; this is a non-existant test called in a waiton. (if (null? tal) test-records (loop (car tal)(cdr tal))) (begin