Index: .mtutil.scm ================================================================== --- .mtutil.scm +++ .mtutil.scm @@ -23,45 +23,46 @@ (define (str-first-char->number str) (char->integer (string-ref str 0))) ;; example of how to set up and write target mappers ;; -(hash-table-set! *target-mappers* - 'prefix-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc contour "/" target))) -(hash-table-set! *target-mappers* - 'prefix-area-contour - (lambda (target run-name area area-path reason contour mode-patt) - (conc area "/" contour "/" target))) - -(hash-table-set! *runname-mappers* - 'corporate-ww - (lambda (target run-name area area-path reason contour mode-patt) - (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) - (let* ((last-name (get-last-runname area-path target)) - (last-letter (let* ((ch (if (string? last-name) - (let ((len (string-length last-name))) - (substring last-name (- len 1) len)) - "a")) - (chnum (str-first-char->number ch)) - (a (str-first-char->number "a")) - (z (str-first-char->number "z"))) - (if (and (>= chnum a)(<= chnum z)) - chnum - #f))) - (next-letter (if last-letter - (list->string - (list - (integer->char - (+ last-letter 1)))) ;; surely there is an easier way? - "a"))) - ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) - (conc (seconds->wwdate (current-seconds)) next-letter)))) - -(hash-table-set! *runname-mappers* - 'auto - (lambda (target run-name area area-path reason contour mode-patt) - "auto-eh")) - -;; (print "Got here!") +(add-target-mapper 'prefix-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc contour "/" target))) +(add-target-mapper 'prefix-area-contour + (lambda (target run-name area area-path reason contour mode-patt) + (conc area "/" contour "/" target))) + +(add-runname-mapper 'corporate-ww + (lambda (target run-name area area-path reason contour mode-patt) + (print "corporate-ww called with: target=" target " run-name=" run-name " area=" area " area-path=" area-path " reason=" reason " contour=" contour " mode-patt=" mode-patt) + (let* ((last-name (get-last-runname area-path target)) + (last-letter (let* ((ch (if (string? last-name) + (let ((len (string-length last-name))) + (substring last-name (- len 1) len)) + "a")) + (chnum (str-first-char->number ch)) + (a (str-first-char->number "a")) + (z (str-first-char->number "z"))) + (if (and (>= chnum a)(<= chnum z)) + chnum + #f))) + (next-letter (if last-letter + (list->string + (list + (integer->char + (+ last-letter 1)))) ;; surely there is an easier way? + "a"))) + ;; (print "last-name: " last-name " last-letter: " last-letter " next-letter: " next-letter) + (conc (seconds->wwdate (current-seconds)) next-letter)))) + +(add-runname-mapper 'auto + (lambda (target run-name area area-path reason contour mode-patt) + "auto-eh")) + +;; run only areas where first letter of area name is "a" +;; +(add-area-checker 'first-letter-a + (lambda (area target contour) + (string-match "^a.*$" area))) + Index: Makefile ================================================================== --- Makefile +++ Makefile @@ -6,14 +6,14 @@ INSTALL=install SRCFILES = common.scm items.scm launch.scm \ ods.scm runconfig.scm server.scm configf.scm \ db.scm keys.scm margs.scm megatest-version.scm \ process.scm runs.scm tasks.scm tests.scm genexample.scm \ - http-transport.scm filedb.scm \ + http-transport.scm filedb.scm tdb.scm \ client.scm synchash.scm daemon.scm mt.scm \ ezsteps.scm lock-queue.scm sdb.scm \ - rmt.scm api.scm tdb.scm rpc-transport.scm \ + rmt.scm api.scm \ portlogger.scm archive.scm env.scm diff-report.scm cgisetup/models/pgdb.scm # Eggs to install (straightforward ones) EGGS=matchable readline apropos base64 regex-literals format regex-case test coops trace csv \ dot-locking posix-utils posix-extras directory-utils hostinfo tcp-server rpc csv-xml fmt \ Index: archive.scm ================================================================== --- archive.scm +++ archive.scm @@ -7,12 +7,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format md5 message-digest srfi-18) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 format md5 message-digest srfi-18) (declare (unit archive)) (declare (uses db)) (declare (uses common)) 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: client.scm ================================================================== --- client.scm +++ client.scm @@ -10,18 +10,13 @@ ;;====================================================================== ;; C L I E N T S ;;====================================================================== -(require-extension (srfi 18) extras tcp s11n) - -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest matchable) -;; (use zmq) - -(use (prefix sqlite3 sqlite3:)) - -(use spiffy uri-common intarweb http-client spiffy-request-vars uri-common intarweb directory-utils) +(use srfi-18 extras tcp s11n srfi-1 posix regex srfi-69 hostinfo md5 + message-digest matchable spiffy uri-common intarweb http-client + spiffy-request-vars uri-common intarweb directory-utils) (declare (unit client)) (declare (uses common)) (declare (uses db)) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -8,14 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (use srfi-1 posix regex-case base64 format dot-locking csv-xml z3 sql-de-lite hostinfo md5 message-digest typed-records directory-utils stack - matchable) -(require-extension regex posix) - -(require-extension (srfi 18) extras tcp rpc) + matchable regex posix srfi-18 extras) (import (prefix sqlite3 sqlite3:)) (import (prefix base64 base64:)) (declare (unit common)) @@ -1031,13 +1028,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) '())) @@ -2147,93 +2148,81 @@ ((equal? status "KILLREQ") "purple") ((equal? status "RUNNING") "blue") ((equal? status "ABORT") "brown") (else "black"))) -;;====================================================================== -;; N A N O M S G C L I E N T -;;====================================================================== - -(define (server:get-best-guess-address hostname) - (let ((res #f)) - (for-each - (lambda (adr) - (if (not (eq? (u8vector-ref adr 0) 127)) - (set! res adr))) - ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME - (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) - (string-intersperse - (map number->string - (u8vector->list - (if res res (hostname->ip hostname)))) "."))) - - -(define (common:send-dboard-main-changed) - (let* ((dashboard-ips (mddb:get-dashboards))) - (for-each - (lambda (ipadr) - (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) - (msg (conc "main " *toppath*)) - (res (common:nm-send-receive-timeout soc msg))) - (if (not res) ;; couldn't reach that dashboard - remove it from db - (print "ERROR: couldn't reach dashboard " ipadr)) - res)) - dashboard-ips))) - - -;;====================================================================== -;; D A S H B O A R D D B -;;====================================================================== - -(define (mddb:open-db) - (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) - (set-busy-handler! db (busy-timeout 10000)) - (for-each - (lambda (qry) - (exec (sql db qry))) - (list - "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" - "CREATE TABLE IF NOT EXISTS dashboards ( - id INTEGER PRIMARY KEY, - pid INTEGER, - username TEXT, - hostname TEXT, - ipaddr TEXT, - portnum INTEGER, - start_time TIMESTAMP DEFAULT (strftime('%s','now')), - CONSTRAINT hostport UNIQUE (hostname,portnum) - );" - )) - db)) - -;; register a dashboard -;; -(define (mddb:register-dashboard port) - (let* ((pid (current-process-id)) - (hostname (get-host-name)) - (ipaddr (server:get-best-guess-address hostname)) - (username (current-user-name)) ;; (car userinfo))) - (db (mddb:open-db))) - (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) - (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") - pid username hostname ipaddr port) - (close-database db))) - -;; unregister a monitor -;; -(define (mddb:unregister-dashboard host port) - (let* ((db (mddb:open-db))) - (print "Register unregister monitor, host:port=" host ":" port) - (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) - (close-database db))) - -;; get registered dashboards -;; -(define (mddb:get-dashboards) - (let ((db (mddb:open-db))) - (query fetch-column - (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) +;; ;;====================================================================== +;; ;; N A N O M S G C L I E N T +;; ;;====================================================================== +;; +;; +;; +;; (define (common:send-dboard-main-changed) +;; (let* ((dashboard-ips (mddb:get-dashboards))) +;; (for-each +;; (lambda (ipadr) +;; (let* ((soc (common:open-nm-req (conc "tcp://" ipadr))) +;; (msg (conc "main " *toppath*)) +;; (res (common:nm-send-receive-timeout soc msg))) +;; (if (not res) ;; couldn't reach that dashboard - remove it from db +;; (print "ERROR: couldn't reach dashboard " ipadr)) +;; res)) +;; dashboard-ips))) +;; +;; +;; ;;====================================================================== +;; ;; D A S H B O A R D D B +;; ;;====================================================================== +;; +;; (define (mddb:open-db) +;; (let* ((db (open-database (conc (get-environment-variable "HOME") "/.dashboard.db")))) +;; (set-busy-handler! db (busy-timeout 10000)) +;; (for-each +;; (lambda (qry) +;; (exec (sql db qry))) +;; (list +;; "CREATE TABLE IF NOT EXISTS vars (id INTEGER PRIMARY KEY,key TEXT, val TEXT, CONSTRAINT varsconstraint UNIQUE (key));" +;; "CREATE TABLE IF NOT EXISTS dashboards ( +;; id INTEGER PRIMARY KEY, +;; pid INTEGER, +;; username TEXT, +;; hostname TEXT, +;; ipaddr TEXT, +;; portnum INTEGER, +;; start_time TIMESTAMP DEFAULT (strftime('%s','now')), +;; CONSTRAINT hostport UNIQUE (hostname,portnum) +;; );" +;; )) +;; db)) +;; +;; ;; register a dashboard +;; ;; +;; (define (mddb:register-dashboard port) +;; (let* ((pid (current-process-id)) +;; (hostname (get-host-name)) +;; (ipaddr (server:get-best-guess-address hostname)) +;; (username (current-user-name)) ;; (car userinfo))) +;; (db (mddb:open-db))) +;; (print "Register monitor, pid: " pid ", hostname: " hostname ", port: " port ", username: " username) +;; (exec (sql db "INSERT OR REPLACE INTO dashboards (pid,username,hostname,ipaddr,portnum) VALUES (?,?,?,?,?);") +;; pid username hostname ipaddr port) +;; (close-database db))) +;; +;; ;; unregister a monitor +;; ;; +;; (define (mddb:unregister-dashboard host port) +;; (let* ((db (mddb:open-db))) +;; (print "Register unregister monitor, host:port=" host ":" port) +;; (exec (sql db "DELETE FROM dashboards WHERE hostname=? AND portnum=?;") host port) +;; (close-database db))) +;; +;; ;; get registered dashboards +;; ;; +;; (define (mddb:get-dashboards) +;; (let ((db (mddb:open-db))) +;; (query fetch-column +;; (sql db "SELECT ipaddr || ':' || portnum FROM dashboards;")))) ;;====================================================================== ;; T E S T L A U N C H I N G P E R I T E M W I T H H O S T T Y P E S ;;====================================================================== ;; 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: docs/Makefile ================================================================== --- docs/Makefile +++ docs/Makefile @@ -13,5 +13,7 @@ fossil add html/* megatest.pdf : megatest.lyx lyx -e pdf2 megatest.lyx +pkts.pdf : pkts.dot + dot -Tpdf pkts.dot -o pkts.pdf ADDED docs/pkts.dot Index: docs/pkts.dot ================================================================== --- /dev/null +++ docs/pkts.dot @@ -0,0 +1,59 @@ +digraph megatest_pkts { + ranksep=0.05 + // rankdir=LR + +node [shape=box,style=filled]; + + "SENSORS" [ label = "{ Sensor Processing | { file | git | fossil | script }}" + shape = "record"; ]; + + "RUNS" [ label = "{ Runs Processing | { launch | clean | re-run | archive } | { dispatcher }}"; + shape = "record"; ]; + + "WORK" [ label = "{ Work Items | { start task | task competed }}"; + shape = "record"; ]; + + "USERREQ" [ label = "{ User Requests (Unix and Web) | { launch | clean | re-run | archive }}"; + shape = "record"; ]; + + "MTAREA1" [ label = "{ Megatest Area 1 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}"; + shape = "record"; ]; + + "MTAREA2" [ label = "{ Megatest Area 2 | { parallel job\nmanagement | test\nmanagement | data\nrollup }}"; + shape = "record"; ]; + + "MTAREA3" [ label = "More Megatest Areas ... "; + shape = "record"; ]; + + "PGDB" [ label = "postgres database"; + shape = "cylinder"; ]; + + "WEBAPP" [ label = "{ Web View | { Runs | Contours | Control | Time View }}"; + shape = "record"; ]; + + // "WEBCTRL" [ label = "{ Web View \n(control) }"; + // shape = "record"; ]; + + "SENSORS" -> "SPKTS"; + "RUNS" -> "run pkts"; + "run pkts" -> "RUNS"; + "WORK" -> "work pkts"; + "work pkts" -> "RUNS"; + "USERREQ" -> "user request pkts"; + "SPKTS" -> "RUNS"; + "user request pkts" -> "RUNS"; + "RUNS" -> "MTAREA1" -> "PGDB"; + "RUNS" -> "MTAREA2" -> "PGDB"; + "RUNS" -> "MTAREA3" -> "PGDB"; + "PGDB" -> "WEBAPP"; + // "WEBCTRL" -> "run pkts"; + + subgraph cluster_pkts { + label="Packets"; + "SPKTS" [ label = "Sensor Packets" ]; + "run pkts"; + "work pkts"; + "user request pkts"; + } +} + ADDED docs/pkts.pdf Index: docs/pkts.pdf ================================================================== --- /dev/null +++ docs/pkts.pdf cannot compute difference between binary files Index: ezsteps.scm ================================================================== --- ezsteps.scm +++ ezsteps.scm @@ -8,12 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking directory-utils) -(import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex srfi-69 directory-utils) (declare (unit ezsteps)) (declare (uses db)) (declare (uses common)) (declare (uses items)) Index: http-transport.scm ================================================================== --- http-transport.scm +++ http-transport.scm @@ -8,12 +8,11 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) -(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) ;; sqlite3 -;; (import (prefix sqlite3 sqlite3:)) +(use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest posix-extras) (use spiffy uri-common intarweb http-client spiffy-request-vars intarweb spiffy-directory-listing) ;; Configurations for server (tcp-buffer-size 2048) Index: keys.scm ================================================================== --- keys.scm +++ keys.scm @@ -64,14 +64,11 @@ ;;====================================================================== ;; 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) (define (keys:make-key/field-string confdat) (let ((fields (configf:get-section confdat "fields"))) (string-join (map (lambda (field)(conc (car field) " " (cadr field))) fields) Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -21,13 +21,10 @@ (declare (unit launch)) (declare (uses common)) (declare (uses configf)) (declare (uses db)) -;; (declare (uses sdb)) -(declare (uses tdb)) -;; (declare (uses filedb)) (include "common_records.scm") (include "key_records.scm") (include "db_records.scm") Index: lock-queue.scm ================================================================== --- lock-queue.scm +++ lock-queue.scm @@ -5,12 +5,11 @@ ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. -(use sqlite3 srfi-18) -(import (prefix sqlite3 sqlite3:)) +(use (prefix sqlite3 sqlite3:) srfi-18) (declare (unit lock-queue)) (declare (uses common)) (declare (uses tasks)) Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two or four digit decimal ;; 1.01, 1.02...1.10,1.11,1.1101 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.6409) +(define megatest-version 1.6501) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -1,23 +1,33 @@ -[fields] -a text -b text -c text +# [fields] +# a text +# b text +# c text + +[defaults] +usercode .mtutil.scm +areafilter area-to-run +targtrans generic-target-translator +runtrans generic-runname-translator [setup] -pktsdirs /tmp/pkts /some/other/source +pktsdirs /tmp/mt_pkts /some/other/source [areas] # path-to-area map-target-script(future, optional) -fullrun path=tests/fullrun +# someqa path=../megatestqa/someqa; targtrans=somefunc; areafilter=area-to-run +fullrun path=tests/fullrun; # targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run +# the target translator can return: a/target OR (list/of targets/to apply/run) OR #f i.e. run nothing # ext-tests path=ext-tests; targtrans=prefix-contour; ext-tests path=ext-tests [contours] # mode-patt/tag-expr -quick selector=QUICKPATT/quick -full areas=fullrun,ext-tests; selector=MAXPATT/ -all areas=fullrun,ext-tests -snazy areas=%; selector=QUICKPATT/ +quick areas=ext-tests; selector=/QUICKPATT +# quick areas=fullrun,ext-tests; selector=QUICKPATT/quick +# full areas=fullrun,ext-tests; selector=MAXPATT/ +# short areas=fullrun,ext-tests; selector=MAXPATT/ +# all areas=fullrun,ext-tests +# snazy selector=QUICKPATT/ [nopurpose] Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -11,20 +11,18 @@ ;; (include "megatest-version.scm") ;; fake out readline usage of toplevel-command (define (toplevel-command . a) #f) -(use sqlite3 srfi-1 posix regex regex-case srfi-69 base64 readline apropos json http-client directory-utils rpc typed-records;; (srfi 18) extras) - http-client srfi-18 extras format) ;; zmq extras) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (prefix base64 base64:) + readline apropos json http-client directory-utils typed-records + http-client srfi-18 extras format) ;; Added for csv stuff - will be removed ;; (use sparse-vectors) -(import (prefix sqlite3 sqlite3:)) -(import (prefix base64 base64:)) -(import (prefix rpc rpc:)) (require-library mutils) ;; (use zmq) (declare (uses common)) Index: mlaunch.scm ================================================================== --- mlaunch.scm +++ mlaunch.scm @@ -15,12 +15,11 @@ ;; take jobs from the given queue and keep launching them keeping ;; the cpu load at the targeted level ;; ;;====================================================================== -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking format) -(import (prefix sqlite3 sqlite3:)) +(use sqlite3 srfi-1 posix regex regex-case srfi-69 format) (declare (unit mlaunch)) (declare (uses db)) (declare (uses common)) 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)) @@ -25,13 +25,58 @@ (include "megatest-fossil-hash.scm") (require-library stml) -(define *target-mappers* (make-hash-table)) ;; '()) -(define *runname-mappers* (make-hash-table)) ;; '()) +;; stuff for the mapper and checker functions +;; +(define *target-mappers* (make-hash-table)) +(define *runname-mappers* (make-hash-table)) +(define *area-checkers* (make-hash-table)) + +;; helpers for mappers/checkers +(define (add-target-mapper name proc) + (hash-table-set! *target-mappers* name proc)) +(define (add-runname-mapper name proc) + (hash-table-set! *runname-mappers* name proc)) +(define (add-area-checker name proc) + (hash-table-set! *area-checkers* name proc)) + +;; given a runkey, xlatr-key and other info return one of the following: +;; list of targets, null list to skip processing +;; +(define (map-targets mtconf aval-alist runkey area contour #!key (xlatr-key-in #f)) + (let* ((xlatr-key (or xlatr-key-in + (conf-get/default mtconf aval-alist 'targtrans))) + (proc (hash-table-ref/default *target-mappers* xlatr-key #f))) + (if proc + (begin + (print "Using target mapper: " area-xlatr) + (handle-exceptions + exn + (begin + (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr) + (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) ) + (print " message: " ((condition-property-accessor 'exn 'message) exn)) + runkey) + (proc runkey area contour))) + (begin + (if xlatr-key + (print "ERROR: Failed to find named target translator " xlatr-key ", using original target.")) + `(,runkey))))) ;; no proc then use runkey +;; given mtconf and areaconf extract a translator/filter, first look at areaconf +;; then if not found look at default +;; +(define (conf-get/default mtconf areaconf keyname #!key (default #f)) + (let ((res (or (alist-ref keyname areaconf) + (configf:lookup mtconf "default" (conc keyname)) + default))) + (if res + (string->symbol res) + res))) + ;; this needs some thought regarding security implications. ;; ;; i. Check that owner of the file and calling user are same? ;; ii. Check that we are in a legal megatest area? ;; iii. Have some form of authentication or record of the md5sum or similar of the file? @@ -40,11 +85,11 @@ ;; (if (file-exists? "megatest.config") (if (file-exists? ".mtutil.so") (load ".mtutil.so") (if (file-exists? ".mtutil.scm") - (load ".mtutil.scm")))) + (load ".mtutil.scm")))) ;; Disabled help items ;; -rollup : (currently disabled) fill run (set by :runname) with latest test(s) ;; from prior runs with same keys ;; Contour actions @@ -56,55 +101,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,49 +157,74 @@ 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") (sync . "") (archive . "-archive") (set-ss . "-set-state-status"))) + +;; Card types: +;; +;; A action +;; U username (Unix) +;; D timestamp +;; T card type + +;; utilitarian alist for standard cards +;; +(define *additional-cards* + '( + ;; Standard Cards + (A . action ) + (D . timestamp ) + (T . cardtype ) + (U . user ) ;; username + (Z . shar1sum ) + + ;; Extras + (a . runkey ) ;; needed for matching up pkts with target derived from runkey + )) ;; inlst is an alternative input ;; (define (lookup-param-by-key key #!key (inlst #f)) (fold (lambda (a res) @@ -256,22 +327,14 @@ (loop (get-line) date node time)))) (else ;; no more datat and last node on branch not found (close-input-port timeline-port) (values (common:date-time->seconds (conc date " " time)) node)))))) - ;;====================================================================== ;; GLOBALS ;;====================================================================== -;; Card types: -;; -;; a action -;; u username (Unix) -;; D timestamp -;; T card type - ;; process args (define *action* (if (> (length (argv)) 1) (cadr (argv)) #f)) (define remargs (args:get-args @@ -298,10 +361,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 +385,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 +410,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))))) @@ -394,11 +461,11 @@ (if (hash-table? args-alist) ;; seriously? (hash-table->alist args-alist) args-alist) (hash-table->alist args:arg-hash))) ;; if no args-alist then we assume this is a call driven directly by commandline (alldat (apply append (list 'T "cmd" - 'a action + 'A action 'U (current-user-name) 'D sched) extra-dat (map (lambda (x) (let* ((param (car x)) @@ -410,12 +477,12 @@ #f))) (if (or pmeta smeta) ;; construct the switch/param pair. (list meta value) '()))) (filter cdr args-data))))) -;; (print "Alldat: " alldat -;; " args-data: " args-data) + (print "Alldat: " alldat + " args-data: " args-data) (add-z-card (apply construct-sdat alldat)))) (define (simple-setup start-dir-in) (let* ((start-dir (or start-dir-in ".")) @@ -444,16 +511,19 @@ ;; ii. Pass the pkt keys and values to this proc and go from there. ;; iii. Maybe have an abstraction alist with meaningful names for the pkt keys ;; ;; Override the run start time record with sched. Usually #f is fine. ;; -(define (create-run-pkt mtconf action area runkey runname mode-patt tag-expr pktsdir reason contour sched dbdest append-conf runtrans) +(define (create-run-pkt mtconf action area runkey target runname mode-patt + tag-expr pktsdir reason contour sched dbdest append-conf + runtrans) (let* ((good-val (lambda (inval)(and inval (string? inval)(not (string-null? inval))))) (area-dat (val->alist (or (configf:lookup mtconf "areas" area) ""))) (area-path (alist-ref 'path area-dat)) - (area-xlatr (alist-ref 'targtrans area-dat)) - (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f)) + ;; (area-xlatr (alist-ref 'targtrans area-dat)) + ;; (xlatr-key (if area-xlatr (string->symbol area-xlatr) #f)) + (new-runname (let* ((callname (if (string? runtrans)(string->symbol runtrans) #f)) (mapper (if callname (hash-table-ref/default *runname-mappers* callname #f) #f))) ;; (print "callname=" callname " runtrans=" runtrans " mapper=" mapper) (if (and callname (not (equal? callname "auto")) (not mapper)) @@ -469,37 +539,25 @@ (print "(mapper " (string-intersperse (list runkey runname area area-path reason contour mode-patt) ", ") ")") (mapper runkey runname area area-path reason contour mode-patt)) (case callname ((auto) runname) (else runtrans))))) - (new-target (if area-xlatr - (let ((xlatr-key (string->symbol area-xlatr))) - (if (hash-table-exists? *target-mappers* xlatr-key) - (begin - (print "Using target mapper: " area-xlatr) - (handle-exceptions - exn - (begin - (print "FAILED TO RUN TARGET MAPPER FOR " area ", called " area-xlatr) - (print " function is: " (hash-table-ref/default *target-mappers* xlatr-key #f ) ) - (print " message: " ((condition-property-accessor 'exn 'message) exn)) - runkey) - ((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))) + (new-target target) ;; I believe we will want target manipulation here .. (map-targets xlatr-key runkey area contour)) + (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) + ;; (print "area-path: " area-path " 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 +564,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")) @@ -516,25 +575,36 @@ `(("-preclean" . " ") ("-rerun-all" . " ")) ;; if run we *always* want preclean set, use single space as placeholder '()) ) sched - extra-dat: `((a . ,runkey)) ;; we need the run key for marking the run as launched + extra-dat: `(a ,runkey) ;; we need the run key for marking the run as launched ))) (with-output-to-file (conc pktsdir "/" uuid ".pkt") (lambda () (print pkt)))))) - +;; look for areas=a1,a2,a3 OR areafn=somefuncname +;; (define (val-alist->areas val-alist) - (string-split (or (alist-ref 'areas val-alist) "") ",")) + (let ((areas-string (alist-ref 'areas val-alist)) + (areas-procname (alist-ref 'areafn val-alist))) + (if areas-procname ;; areas-procname take precedence + areas-procname + (string-split (or areas-string "") ",")))) -(define (area-allowed? area areas) - (or (not areas) - (null? areas) - (member area areas))) +(define (area-allowed? area areas runkey contour) + (cond + ((not areas) #t) ;; no spec + ((string? areas) ;; + (let ((check-fn (hash-table-ref/default *area-checkers* areas #f))) + (if check-fn + (check-fn area runkey contour) + #f))) + ((list? areas)(member area areas)) + (else #f))) ;; shouldn't get here ;; (use trace)(trace create-run-pkt) ;; collect all needed data and create run pkts for contours with changed inputs ;; @@ -567,26 +637,35 @@ (optional (if (> len-key 3)(cadddr keyparts) #f)) ;; (val-list (string-split-fields ";\\s*" val #:infix)) ;; (string-split val)) ;; runname-rule params (val-alist (val->alist val)) (runname (make-runname "" "")) (runtrans (alist-ref 'runtrans val-alist)) + + ;; these may or may not be defined and not all are used in each handler type in the case below + (run-name (alist-ref 'run-name val-alist)) + (target (alist-ref 'target val-alist)) + (crontab (alist-ref 'cron val-alist)) + (areas (val-alist->areas val-alist)) ;; areas can be a single string (a reference to call an areas function), or a list of area names. + (dbdest (alist-ref 'dbdest val-alist)) + (appendconf (alist-ref 'appendconf val-alist)) + (file-globs (alist-ref 'glob val-alist)) (runstarts (find-pkts pdb '(runstart) `((o . ,contour) (t . ,runkey)))) (rspkts (get-pkt-alists runstarts)) ;; starttimes is for run start times and is used to know when the last run was launched (starttimes (get-pkt-times rspkts)) ;; sort by age (youngest first) and delete duplicates by target - (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max - 0 - (apply max (map cdr starttimes)))) + (last-run (if (null? starttimes) ;; if '() then it has never been run, else get the max + 0 + (apply max (map cdr starttimes)))) ;; synctimes is for figuring out the last time a sync was done - (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc. - (sspkts (get-pkt-alists syncstarts)) - (synctimes (get-pkt-times sspkts)) - (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max - 0 - (apply max (map cdr synctimes)))) + (syncstarts (find-pkts pdb '(syncstart) '())) ;; no qualifiers, a sync does all tarets etc. + (sspkts (get-pkt-alists syncstarts)) + (synctimes (get-pkt-times sspkts)) + (last-sync (if (null? synctimes) ;; if '() then it has never been run, else get the max + 0 + (apply max (map cdr synctimes)))) ) (let ((delta (lambda (x) (round (/ (- (current-seconds) x) 60))))) (print "runkey: " runkey ", ruletype: " ruletype ", action: " action ", last-run: " last-run " time since; last-run: " (delta last-run) ", last-sync: " (delta last-sync))) @@ -600,49 +679,53 @@ (case (string->symbol (or ruletype "no-such-rule")) ((no-such-rule) (print "ERROR: no such rule for " sense)) + ;; Handle crontab like rules + ;; ((scheduled) (if (not (alist-ref 'cron val-alist)) ;; gotta have cron spec (print "ERROR: bad sense spec \"" (string-intersperse sense " ") "\" params: " val-alist) - (let* ((run-name (alist-ref 'run-name val-alist)) - (target (alist-ref 'target val-alist)) - (crontab (alist-ref 'cron val-alist)) - (areas (val-alist->areas val-alist)) + (let* ( ;; (action (alist-ref 'action val-alist)) - (cron-safe-string (string-translate (string-intersperse (string-split (alist-ref 'cron val-alist)) "-") "*" "X")) + (cron-safe-string (string-translate (string-intersperse (string-split crontab) "-") "*" "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)) - (append . ,(alist-ref 'appendconf val-alist)))))) + (dbdest . ,dbdest) + (append . ,appendconf) + (areas . ,areas))))) ((run) (if (common:extended-cron crontab #f last-run) (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" cron-safe-string)) - (runname . ,runname) + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) (runtrans . ,runtrans) - (action . ,action) - (target . ,target))))) + (action . ,action) + (areas . ,areas) + (target . ,target))))) ((remove) (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" cron-safe-string)) - (runname . ,runname) + `((message . ,(conc ruletype ":" cron-safe-string)) + (runname . ,runname) (runtrans . ,runtrans) - (action . ,action) - (target . ,target)))) + (action . ,action) + (areas . ,areas) + (target . ,target)))) (else (print "ERROR: action \"" action "\" has no scheduled handler") ))))) + ;; script based sensors + ;; ((script) ;; syntax is a little different here. It is a list of commands to run, "scriptname = extra_parameters;scriptname = ..." ;; where scriptname may be repeated multiple times. The script must return unix-epoch of last change, new-target-name and new-run-name ;; the script is called like this: scriptname contour runkey std-runname action extra_param1 extra_param2 ... (for-each @@ -675,19 +758,23 @@ (if need-run (let* ((key-msg `((message . ,(conc ruletype ":" message)) (runname . ,runname) (runtrans . ,runtrans) (action . ,action) - (target . ,new-target)))) + (areas . ,areas) + (target . ,new-target) ;; overriding with result from runing the script + ))) (print "key-msg: " key-msg) (push-run-spec torun contour (if optional ;; we need to be able to differentiate same contour, different behavior. (conc runkey ":" optional) ;; NOTE: NOT COMPLETELY IMPLEMENTED. DO NOT USE runkey) key-msg))))))) val-alist)) ;; iterate over the param split by ;\s* + ;; fossil scm based triggers + ;; ((fossil) (for-each (lambda (fspec) (print "fspec: " fspec) (let* ((url (symbol->string (car fspec))) ;; THIS COULD BE TROUBLE. Add option to reading line to return as string. @@ -699,66 +786,73 @@ (fossil:clone-or-sync url fname fdir) ;; ) (let-values (((datetime node) (fossil:last-change-node-and-time fdir fname branch))) (if (null? starttimes) (push-run-spec torun contour runkey - `((message . ,(conc "fossil:" branch "-neverrun")) - (runname . ,(conc runname "-" node)) + `((message . ,(conc "fossil:" branch "-neverrun")) + (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) - (target . ,runkey))) + (areas . ,areas) + ;; (target . ,runkey) + )) (if (> datetime last-run) ;; change time is greater than last-run time (push-run-spec torun contour runkey - `((message . ,(conc "fossil:" branch "-" node)) - (runname . ,(conc runname "-" node)) + `((message . ,(conc "fossil:" branch "-" node)) + (runname . ,(conc runname "-" node)) (runtrans . ,runtrans) - (target . ,runkey))))) + (areas . ,areas) + ;; (target . ,runkey) + )))) (print "Got datetime=" datetime " node=" node)))) val-alist)) - + + ;; sensor looking for one or more files newer than reference + ;; ((file file-or) ;; one or more files must be newer than the reference - (let* ((file-globs (alist-ref 'glob val-alist)) - (areas (val-alist->areas val-alist)) - (youngestdat (common:get-youngest (common:bash-glob file-globs))) + (let* ((youngestdat (common:get-youngest (common:bash-glob file-globs))) (youngestmod (car youngestdat))) ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey - `((message . "file:neverrun") - (action . ,action) + `((message . "file:neverrun") + (action . ,action) (runtrans . ,runtrans) - (target . ,runkey) - (runname . ,runname))) + ;; (target . ,runkey) + (areas . ,areas) + (runname . ,runname))) ;; (for-each ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour ;; (if (> youngestmod (cdr starttime)) ;; (begin ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (if (> youngestmod last-run) (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" (cadr youngestdat))) - (action . ,action) - (target . ,runkey) + `((message . ,(conc ruletype ":" (cadr youngestdat))) + (action . ,action) + ;; (target . ,runkey) (runtrans . ,runtrans) - (runname . ,runname) + (areas . ,areas) + (runname . ,runname) )))))) - ;; starttimes)) + ;; all globbed files must be newer than the reference + ;; ((file-and) ;; all files must be newer than the reference - (let* ((file-globs (alist-ref 'glob val-alist)) - (youngestdat (common:get-youngest file-globs)) + (let* ((youngestdat (common:get-youngest file-globs)) (youngestmod (car youngestdat)) (success #t)) ;; any cases of not true, set flag to #f for AND ;; (print "youngestmod: " youngestmod " starttimes: " starttimes) (if (null? starttimes) ;; this target has never been run (push-run-spec torun contour runkey - `((message . "file:neverrun") - (runname . ,runname) + `((message . "file:neverrun") + (runname . ,runname) (runtrans . ,runtrans) - (target . ,runkey) - (action . ,action))) + (areas . ,areas) + ;; (target . ,runkey) + (action . ,action))) ;; NB// I think this is wrong. It should be looking at last-run only. - (if (> youngestmod last-run) + (if (> youngestmod last-run) ;; WAIT!! Shouldn't file-and be looking at the *oldest* file (thus all are younger than ...) ;; (for-each ;; (lambda (starttime) ;; look at the time the last run was kicked off for this contour ;; (if (< youngestmod (cdr starttime)) ;; (set! success #f))) @@ -765,78 +859,89 @@ ;; starttimes)) ;; (if success ;; (begin ;; (print "starttime younger than youngestmod: " starttime " Youngestmod: " youngestmod) (push-run-spec torun contour runkey - `((message . ,(conc ruletype ":" (cadr youngestdat))) - (runname . ,runname) + `((message . ,(conc ruletype ":" (cadr youngestdat))) + (runname . ,runname) (runtrans . ,runtrans) - (target . ,runkey) - (action . ,action) + ;; (target . ,runkey) + (areas . ,areas) + (action . ,action) )))))) (else (print "ERROR: unrecognised rule \"" ruletype))))) keydats))) ;; sense rules (hash-table-keys rgconf)) ;; now have to run populated (for-each (lambda (contour) - (print "contour: " contour) - (let* ((val (or (configf:lookup mtconf "contours" contour) "")) - (val-alist (val->alist val)) - (areas (val-alist->areas val-alist)) - (selector (alist-ref 'selector val-alist)) - (mode-tag (and selector (string-split-fields "/" selector #:infix))) - (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) - (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) + (let* ((cval (or (configf:lookup mtconf "contours" contour) "")) + (cval-alist (val->alist cval)) ;; BEWARE ... NOT the same val-alist as above! + (areas (val-alist->areas cval-alist)) + (selector (alist-ref 'selector cval-alist)) + (mode-tag (and selector (string-split-fields "/" selector #:infix))) + (mode-patt (and mode-tag (if (eq? (length mode-tag) 2)(cadr mode-tag) #f))) + (tag-expr (and mode-tag (if (null? mode-tag) #f (car mode-tag))))) + (print "contour: " contour " areas=" areas " cval=" cval) (for-each (lambda (runkeydatset) ;; (print "runkeydatset: ")(pp runkeydatset) (let ((runkey (car runkeydatset)) (runkeydats (cadr runkeydatset))) (for-each (lambda (runkeydat) (for-each (lambda (area) - (if (area-allowed? area areas) ;; is this area to be handled (from areas=a,b,c ...) - (let ((runname (alist-ref 'runname runkeydat)) - (runtrans (alist-ref 'runtrans runkeydat)) - (reason (alist-ref 'message runkeydat)) - (sched (alist-ref 'sched runkeydat)) - (action (alist-ref 'action runkeydat)) - (dbdest (alist-ref 'dbdest runkeydat)) - (append (alist-ref 'append runkeydat)) - (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)) - (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) - )) - (print "NOTE: skipping " runkeydat " for area, not in " areas))) - all-areas)) + (if (area-allowed? area areas runkey contour) ;; is this area to be handled (from areas=a,b,c OR using areafn=abcfn and *area-checks* ...) + (let* ((aval (or (configf:lookup mtconf "areas" area) "")) + (aval-alist (val->alist aval)) + (runname (alist-ref 'runname runkeydat)) + (runtrans (alist-ref 'runtrans runkeydat)) + + (reason (alist-ref 'message runkeydat)) + (sched (alist-ref 'sched runkeydat)) + (action (alist-ref 'action runkeydat)) + (dbdest (alist-ref 'dbdest runkeydat)) + (append (alist-ref 'append runkeydat)) + (targets (or (alist-ref 'target runkeydat) + (map-targets mtconf aval-alist runkey area contour)))) ;; override with target if forced + ;; NEED TO EXPAND RUNKEY => ALL TARGETS MAPPED AND THEN FOREACH .... + (for-each + (lambda (target) + (print "Creating pkt for runkey=" runkey " target=" target " contour=" contour " area=" area " action=" action " tag-expr=" tag-expr " mode-patt=" mode-patt) + (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 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 target 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) + )) + targets)) + (print "NOTE: skipping " runkeydat " for area \"" area "\", not in " areas))) + all-areas)) runkeydats))) (let ((res (configf:get-section torun contour))) ;; each contour / target ;; (print "res=" res) res)))) (hash-table-keys torun))))))) (define (pkt->cmdline pkta) - (let ((action (or (lookup-action-by-key (alist-ref 'a pkta)) "noaction"))) + (let ((action (or (lookup-action-by-key (alist-ref 'A pkta)) "noaction"))) (fold (lambda (a res) (let* ((key (car a)) ;; get the key name (val (cdr a)) (par (or (lookup-param-by-key key) ;; need to check also if it is a switch (lookup-param-by-key key inlst: *switch-keys*)))) ;; (print "key: " key " val: " val " par: " par) (if par (conc res " " (param-translate par) " " val) - (if (member key '(a Z U D T)) ;; a is the action + (if (alist-ref key *additional-cards*) ;; these cards do not translate to parameters or switches res (begin (print "ERROR: Unknown key in packet \"" key "\" with value \"" val "\"") res))))) (conc "megatest " (if (not (member action '("sync"))) @@ -879,11 +984,11 @@ (torun (make-hash-table)) ;; target => ( ... info ... ) (rgentargs (hash-table-keys rgconf))) ;; these are the targets registered for automatically triggering (for-each (lambda (pktdat) (let* ((pkta (alist-ref 'apkt pktdat)) - (action (alist-ref 'a pkta)) + (action (alist-ref 'A pkta)) (cmdline (pkt->cmdline pkta)) (uuid (alist-ref 'Z pkta)) (logf (conc logdir "/" uuid "-run.log")) (fullcmd (conc "NBFAKE_LOG=" logf " nbfake " cmdline))) (print "RUNNING: " fullcmd) @@ -910,11 +1015,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 +1042,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 +1104,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: process.scm ================================================================== --- process.scm +++ process.scm @@ -13,11 +13,10 @@ ;; Process convience utils ;;====================================================================== (use regex) (declare (unit process)) -;;(declare (uses common)) (define (process:conservative-read port) (let loop ((res "")) (if (not (eof-object? (peek-char port))) (loop (conc res (read-char port))) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -11,13 +11,11 @@ (use format typed-records) ;; RADT => purpose of json format?? (declare (unit rmt)) (declare (uses api)) -(declare (uses tdb)) (declare (uses http-transport)) -;;(declare (uses nmsg-transport)) (include "common_records.scm") ;; ;; THESE ARE ALL CALLED ON THE CLIENT SIDE!!! ;; @@ -755,14 +753,10 @@ ;; T E S T D A T A ;;====================================================================== (define (rmt:read-test-data run-id test-id categorypatt #!key (work-area #f)) (rmt:send-receive 'read-test-data run-id (list run-id test-id categorypatt))) -;; (let ((tdb (rmt:open-test-db-by-test-id run-id test-id work-area: work-area))) -;; (if tdb -;; (tdb:read-test-data tdb test-id categorypatt) -;; '()))) (define (rmt:testmeta-add-record testname) (rmt:send-receive 'testmeta-add-record #f (list testname))) (define (rmt:testmeta-get-record testname) 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 -short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm +# commented out for debug +quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm foo.touchme +# 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 @@ -8,13 +8,12 @@ ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;; strftime('%m/%d/%Y %H:%M:%S','now','localtime') -(use sqlite3 srfi-1 posix regex regex-case srfi-69 dot-locking (srfi 18) +(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18) posix-extras directory-utils pathname-expand typed-records format) -(import (prefix sqlite3 sqlite3:)) (declare (unit runs)) (declare (uses db)) (declare (uses common)) (declare (uses items)) @@ -1238,11 +1237,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 +1509,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: server.scm ================================================================== --- server.scm +++ server.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2012, Matthew Welland. +;; Copyright 2006-2017, Matthew Welland. ;; ;; This program is made available under the GNU GPL version 2.0 or ;; greater. See the accompanying file COPYING for details. ;; ;; This program is distributed WITHOUT ANY WARRANTY; without even the @@ -9,11 +9,10 @@ ;; PURPOSE. (require-extension (srfi 18) extras tcp s11n) (use srfi-1 posix regex regex-case srfi-69 hostinfo md5 message-digest directory-utils posix-extras matchable) -;; (use zmq) (use spiffy uri-common intarweb http-client spiffy-request-vars) (declare (unit server)) @@ -20,12 +19,10 @@ (declare (uses common)) (declare (uses db)) (declare (uses tasks)) ;; tasks are where stuff is maintained about what is running. (declare (uses synchash)) (declare (uses http-transport)) -(declare (uses rpc-transport)) -;;(declare (uses nmsg-transport)) (declare (uses launch)) (declare (uses daemon)) (include "common_records.scm") (include "db_records.scm") @@ -435,5 +432,18 @@ ;; (* 3 24 60 60) ;; default to three days ;;(* 60 60 1) ;; default to one hour (* 60 5) ;; default to five minutes ))) +(define (server:get-best-guess-address hostname) + (let ((res #f)) + (for-each + (lambda (adr) + (if (not (eq? (u8vector-ref adr 0) 127)) + (set! res adr))) + ;; NOTE: This can fail when there is no mention of the host in /etc/hosts. FIXME + (vector->list (hostinfo-addresses (hostname->hostinfo hostname)))) + (string-intersperse + (map number->string + (u8vector->list + (if res res (hostname->ip hostname)))) "."))) + 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 Index: tests/fullrun/runconfigs.config ================================================================== --- tests/fullrun/runconfigs.config +++ tests/fullrun/runconfigs.config @@ -1,10 +1,10 @@ [default] SOMEVAR This should show up in SOMEVAR3 VARNOVAL VARNOVAL_WITHSPACE -QUICK % +QUICKPATT test_mt_vars,test2,priority_9 # target based getting of config file, look at afs.config and nfs.config [include #{getenv fsname}.config] [include #{getenv MT_RUN_AREA_HOME}/common_runconfigs.config]