Index: .mtutil.scm ================================================================== --- .mtutil.scm +++ .mtutil.scm @@ -61,7 +61,7 @@ (hash-table-set! *runname-mappers* 'auto (lambda (target run-name area area-path reason contour mode-patt) "auto-eh")) -(print "Got here!") +;; (print "Got here!") Index: api.scm ================================================================== --- api.scm +++ api.scm @@ -169,10 +169,11 @@ ((delete-run) (apply db:delete-run dbstruct params)) ((lock/unlock-run) (apply db:lock/unlock-run dbstruct params)) ((update-run-event_time) (apply db:update-run-event_time dbstruct params)) ((update-run-stats) (apply db:update-run-stats dbstruct params)) ((set-var) (apply db:set-var dbstruct params)) + ((del-var) (apply db:del-var dbstruct params)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA ADDED cgisetup/css/pjhatwal-modal.css Index: cgisetup/css/pjhatwal-modal.css ================================================================== --- /dev/null +++ cgisetup/css/pjhatwal-modal.css @@ -0,0 +1,43 @@ +.modal { + display: none; /* Hidden by default */ + position: fixed; /* Stay in place */ + z-index: 1; /* Sit on top */ + padding-top: 100px; /* Location of the box */ + left: 0; + top: 0; + width: 100%; /* Full width */ + height: 100%; /* Full height */ + overflow: auto; /* Enable scroll if needed */ + background-color: rgb(0,0,0); /* Fallback color */ + background-color: rgba(0,0,0,0.4); /* Black w/ opacity */ +} + +/* Modal Content */ +.modal-content { + background-color: #fefefe; + margin: auto; + padding: 20px; + border: 1px solid #888; + width: 80%; + top: 50% +} + +/* The Close Button */ +.close { + color: #aaaaaa; + float: right; + font-size: 28px; + font-weight: bold; +} + +.close:hover, +.close:focus { + color: #000; + text-decoration: none; + cursor: pointer; +} + +.vote { + color: #faaaaa; +} + ADDED cgisetup/js/pjhatwal-modal.js Index: cgisetup/js/pjhatwal-modal.js ================================================================== --- /dev/null +++ cgisetup/js/pjhatwal-modal.js @@ -0,0 +1,15 @@ +$(document).ready(function(){ + $(".viewmodal").click(function(){ + var modal = document.getElementById("myModal" + this.id); + // alert(this.id); + modal.style.display = "block"; + + }); + $(".close").click(function(){ + var modal = document.getElementById("myModal" + this.id); + // alert(this.id); + modal.style.display = "none"; + + }); +}); + Index: cgisetup/models/pgdb.scm ================================================================== --- cgisetup/models/pgdb.scm +++ cgisetup/models/pgdb.scm @@ -25,12 +25,17 @@ (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; -(define (pgdb:open configdat #!key (dbname #f)) - (let ((pgconf (or (args:get-arg "-pgsync") (configf:lookup configdat "ext-sync" (or dbname "pgdb"))))) +(define (pgdb:open configdat #!key (dbname #f)(dbispec #f)) + (let ((pgconf (or dbispec + (args:get-arg "-pgsync") + (if configdat + (configf:lookup configdat "ext-sync" (or dbname "pgdb")) + #f) + ))) (if pgconf (let* ((confdat (map (lambda (conf-item) (let ((parts (string-split conf-item ":"))) (if (> (length parts) 1) (let ((key (car parts)) @@ -167,11 +172,11 @@ "SELECT t.id,t.run_id,t.test_name,t.item_path,t.state,t.status,t.host,t.cpuload,t.diskfree,t.uname,t.rundir,t.final_logf,t.run_duration,t.comment,t.event_time,t.archived, r.id,r.target,r.ttype_id,r.run_name,r.state,r.status,r.owner,r.event_time,r.comment FROM tests AS t INNER JOIN runs AS r ON t.run_id=r.id WHERE r.target LIKE ?;" target-patt)) -(define (pgdb:get-stats-given-target dbh ttype-id target-patt) +(define (pgdb:get-stats-given-type-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 ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" "SELECT r.target,COUNT(*) AS total, @@ -179,13 +184,73 @@ 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 t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target;" ttype-id target-patt)) + +(define (pgdb:get-stats-given-target dbh 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 + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.target,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 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) + (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, + 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)) + +(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 + ;; WHERE t.state='COMPLETED' AND ttype_id=? AND r.target LIKE ? GROUP BY r.target,t.status;" + "SELECT r.run_name,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 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, + 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;" + target-patt)) + (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-targets dbh target-patt) (let ((ttypes (pgdb:get-target-types dbh))) (map @@ -239,10 +304,62 @@ (hash-table-set! data first newht) (set! coldat newht))) (hash-table-set! coldat rest run))) runs) data)) + +;; given ordered data hash return a-keys +;; +(define (pgdb:ordered-data->a-keys ordered-data) + (sort (hash-table-keys ordered-data) string>=?)) + +;; given ordered data hash return b-keys +;; +(define (pgdb:ordered-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + +;; given ordered data hash return a-keys +;; +(define (pgdb:ordered-data->a-keys ordered-data) + (sort (hash-table-keys ordered-data) string>=?)) + +;; given ordered data hash return b-keys +;; +(define (pgdb:ordered-data->b-keys ordered-data a-keys) + (delete-duplicates + (sort (apply + append + (map (lambda (sub-key) + (let ((subdat (hash-table-ref ordered-data sub-key))) + (hash-table-keys subdat))) + a-keys)) + string>=?))) + +(define (pgdb:coalesce-runs-by-slice runs slice) + (let* ((data (make-hash-table))) + (for-each + (lambda (run) + (let* ((target (vector-ref run 0)) + (run-name (vector-ref run 1)) + (parts (string-split target "/")) + (first (car parts)) + (rest (string-intersperse (cdr parts) "/")) + (coldat (hash-table-ref/default data rest #f))) + (if (not coldat)(let ((newht (make-hash-table))) + (hash-table-set! data rest newht) + (set! coldat newht))) + (hash-table-set! coldat run-name run))) + runs) + data)) + (define (pgdb:runs-to-hash runs ) (let* ((data (make-hash-table))) (for-each (lambda (run) @@ -253,5 +370,14 @@ (hash-table-set! data run-name newht) (set! coldat newht))) (hash-table-set! coldat test run))) runs) data)) + +(define (pgdb:get-history-hash runs) + (let* ((data (make-hash-table))) + (for-each + (lambda (run) + (let* ((run-name (vector-ref run 0))) + (hash-table-set! data run-name run))) + runs) + data)) Index: cgisetup/pages/home_ctrl.scm ================================================================== --- cgisetup/pages/home_ctrl.scm +++ cgisetup/pages/home_ctrl.scm @@ -25,7 +25,16 @@ (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))))) + (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))) +)) Index: cgisetup/pages/home_view.scm ================================================================== --- cgisetup/pages/home_view.scm +++ cgisetup/pages/home_view.scm @@ -10,81 +10,128 @@ ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) (ttypes (pgdb:get-target-types dbh)) - (selected (string->number (or (s:get "target-type") "0"))) + (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)) - ;; (target (s:session-var-get "target")) - ;; (target-patt (or target "%")) (row-or-col (string-split (or (s:get "row-or-col") "") ",")) - (all-data (if selected (pgdb:get-stats-given-target dbh selected tfilter) - '())) - ;; (all-data (pgdb:get-tests dbh tfilter)) - (ordered-data (pgdb:coalesce-runs dbh all-data all-parts row-or-col 0))) - - (s:div 'class "col_12" - (s:fieldset - "Area type and target filter" + (all-data (if (and selected + (not (eq? selected -1))) + (pgdb:get-latest-run-stats-given-target dbh selected tfilter) + '() + ; (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))) + (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" + (s:div 'class "col_11" + (s:fieldset "Area type and target filter" (s:form - 'action "home.filter" 'method "get" + 'action "home.filter#tabr2" 'method "post" (s:div 'class "col_12" (s:div 'class "col_6" (s:select (map (lambda (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)))) - ttypes) + (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_2" - (s:input 'type "submit" 'name "set-filter-vals" 'value "Submit"))) - ;; use radio buttons to select whether to put this identifier in row or column. - ;; this seems clumsly and takes up a lot of screen realestate - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "identifier") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" target-var)) - ;; all-parts)) - ;; (s:div 'class "col_12" - ;; (s:div 'class "col_1" "row") - ;; (map (lambda (target-var) - ;; (s:div 'class "col_1" (s:input 'type "checkbox" 'name "row-or-col" 'value target-var - ;; ;; this silly trick preserves the checkmark - ;; (if (member target-var row-or-col) 'checked "") - ;; ""))) - ;; all-parts)) - )) + (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 " tfilter) + (s:fieldset (conc "Runs data for " tfilter) ;; ;; A very basic display ;; - (let* ((a-keys (sort (hash-table-keys ordered-data) string>=?)) - (b-keys (delete-duplicates(sort (apply - append - (map (lambda (sub-key) - (let ((subdat (hash-table-ref ordered-data sub-key))) - (hash-table-keys subdat))) - a-keys)) - string>=?)))) - ; (c-keys (delete-duplicates b-keys))) - (if #f ;; swap rows/cols + (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)) + (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 @@ -93,13 +140,16 @@ (s:td (if dat (list (vector-ref dat 0)(vector-ref dat 1)) ""))))) b-keys)))) a-keys)) - - (s:table - (s:tr (s:td "")(map s:td a-keys)) + (s:table 'class "striped" + (s:tr (s:th 'class "heading" ) + (map + (lambda (th-key) + (s:th 'class "heading" th-key )) + a-keys)) (map (lambda (row-key) (s:tr (s:td row-key) (map (lambda (col-key) @@ -108,19 +158,44 @@ (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)) (passper (round (* (/ pass total) 100))) (failper (- 100 passper)) - (run-key ;; (string-substitute ;; %2F = / - ;; "-" "%2D" - ;;(string-substitute "/" "%2F" (conc col-key "/" row-key) 'all) - (string-substitute "[/]" "_x_" (conc col-key "/" row-key) 'all) - ;; 'all))) - )) + (history (pgdb:get-run-stats-history-given-target dbh selected (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 'href (s:link-to "run" 'target run-key) - (conc total "/" pass "/" fail "/" other)))) + (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) + (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 + (s:table + (s:tr + (s:th "Runame") + (s:th "Result") + ) + (map + (lambda (history-key) + (let* ((history-row (hash-table-ref/default history-hash history-key #f)) + (htotal (vector-ref history-row 1)) + (hpass (vector-ref history-row 2)) + (hfail (vector-ref history-row 3)) + (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))) + +)) + )) (s:td "")))) a-keys))) - b-keys)))))))) + b-keys))))))) +))) Index: cgisetup/pages/index_ctrl.scm ================================================================== --- cgisetup/pages/index_ctrl.scm +++ cgisetup/pages/index_ctrl.scm @@ -26,17 +26,25 @@ + EOF ) @@ -56,8 +64,9 @@ (define index:javascript #< + EOF ) Index: cgisetup/pages/run_view.scm ================================================================== --- cgisetup/pages/run_view.scm +++ cgisetup/pages/run_view.scm @@ -15,12 +15,13 @@ (s:get "target") (s:get-param 'target))) (target (if (equal? target1 #f) "%" (string-substitute "_x_" "/" target1 'all) - )) - (run-filter (or (s:get "run-name-filter") "%")) + )) + + (run-filter (or (or (s:get "run-name-filter") (s:get-param 'run)) "%")) (runs (pgdb:get-runs-by-target dbh target run-filter)) (ordered-runs (pgdb:runs-to-hash runs))) (s:div 'class "col_12" (s:fieldset @@ -64,11 +65,11 @@ (test-id (vector-ref val 4)) (bg (if (equal? result "PASS") "green" "red"))) (s:td 'style (conc "background: " bg ) - (s:a 'href (s:link-to "log" 'testid test-id) + (s:a 'class "white" 'href (s:link-to "log" 'testid test-id) result))) (s:td "")))) a-keys))) b-keys))))))) Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -1683,20 +1683,28 @@ #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== +(define (bb-check-path #!key (msg "check-path: ")) + (let ((path (or (get-environment-variable "PATH") "none"))) + (debug:print-info 0 *default-log-port* (conc msg" : $PATH="path)) + (if (string-match "^.*/isoenv-core/.*" path) + (debug:print-error 0 *default-log-port* (conc msg" : !!ISOENV PRESENT!!")) ;; remove for prod + (debug:print-info 1 *default-log-port* (conc msg" : **no isoenv present**"))))) + (define (save-environment-as-files fname #!key (ignorevars (list "USER" "HOME" "DISPLAY" "LS_COLORS" "XKEYSYMDB" "EDITOR" "MAKEFLAGS" "MAKEF" "MAKEOVERRIDES"))) + ;;(bb-check-path msg: "save-environment-as-files entry") (let ((envvars (get-environment-variables)) (whitesp (regexp "[^a-zA-Z0-9_\\-:,.\\/%$]")) (mungeval (lambda (val) (cond ((eq? val #t) "") ;; convert #t to empty string ((eq? val #f) #f) ;; convert #f to itself (still thinking about this one (else val))))) - (with-output-to-file (conc fname ".csh") + (with-output-to-file (conc fname ".csh") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) @@ -2083,10 +2091,28 @@ (number->string x 16)) (map string->number (string-split instr))) "/")) +(define (common:faux-lock keyname) + (if (rmt:get-var keyname) + #f + (begin + (rmt:set-var keyname (conc (current-process-id))) + (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))))) + +(define (common:faux-unlock keyname #!key (force #f)) + (if (or force (equal? (conc (current-process-id)) (conc (rmt:get-var keyname)))) + (begin + (if (rmt:get-var keyname) (rmt:del-var keyname)) + #t) + #f)) + + +(define (common:in-running-test?) + (and (args:get-arg "-execute") (get-environment-variable "MT_CMDINFO"))) + (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") Index: configf.scm ================================================================== --- configf.scm +++ configf.scm @@ -64,11 +64,11 @@ ;;====================================================================== ;; Make the regexp's needed globally available ;;====================================================================== (define configf:include-rx (regexp "^\\[include\\s+(.*)\\]\\s*$")) -(define configf:script-rx (regexp "^\\[scriptinc\\s+(.*)\\]\\s*$")) ;; include output from a script +(define configf:script-rx (regexp "^\\[scriptinc\\s+(\\S+)([^\\]]*)\\]\\s*$")) ;; include output from a script (define configf:section-rx (regexp "^\\[(.*)\\]\\s*$")) (define configf:blank-l-rx (regexp "^\\s*$")) (define configf:key-sys-pr (regexp "^(\\S+)\\s+\\[system\\s+(\\S+.*)\\]\\s*$")) (define configf:key-val-pr (regexp "^(\\S+)(\\s+(.*)|())$")) (define configf:key-no-val (regexp "^(\\S+)(\\s*)$")) @@ -292,17 +292,17 @@ (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (begin (debug:print '(2 9) #f "INFO: include file " include-file " not found (called from " path ")") (debug:print 2 *default-log-port* " " full-conf) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f))))) - (configf:script-rx ( x include-script );; handle-exceptions - ;; exn - ;; (begin - ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") - ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) + (configf:script-rx ( x include-script params);; handle-exceptions + ;; exn + ;; (begin + ;; (debug:print '(0 2 9) #f "INFO: include from script " include-script " failed.") + ;; (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) (if (and (file-exists? include-script)(file-execute-access? include-script)) - (let* ((new-inp-port (open-input-pipe include-script))) + (let* ((new-inp-port (open-input-pipe (conc include-script " " params)))) (debug:print '(2 9) *default-log-port* "Including from script output: " include-script) ;; (print "We got here, calling read-config next. Port is: " new-inp-port) (read-config new-inp-port res allow-system environ-patt: environ-patt curr-section: curr-section-name sections: sections settings: settings keep-filenames: keep-filenames) (close-input-port new-inp-port) (loop (configf:read-line inp res (calc-allow-system allow-system curr-section-name sections) settings) curr-section-name #f #f)) @@ -663,25 +663,35 @@ #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) - (let ((dat (configf:config->alist cdat))) - (with-output-to-file fname ;; first write out the file - (lambda () - (pp dat))) - (if (common:file-exists? fname) ;; now verify it is readable - (if (configf:read-alist fname) - #t ;; data is good. - (begin - (handle-exceptions - exn - #f - (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") - (delete-file fname)) - #f)) - #f))) + (if (common:faux-lock fname) + (let* ((dat (configf:config->alist cdat)) + (res + (begin + (with-output-to-file fname ;; first write out the file + (lambda () + (pp dat))) + + (if (common:file-exists? fname) ;; now verify it is readable + (if (configf:read-alist fname) + #t ;; data is good. + (begin + (handle-exceptions + exn + #f + (debug:print 0 *default-log-port* "WARNING: content " dat " for cache " fname " is not readable. Deleting generated file.") + (delete-file fname)) + #f)) + #f)))) + + (common:faux-unlock fname) + res) + (begin + (debug:print 0 *default-log-port* "WARNING: could not get faux-lock on " fname) + #f))) ;; convert hierarchial list to ini format ;; (define (configf:config->ini data) (map Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -150,14 +150,19 @@ )) ;; RA => returns the tabdat stored at hashkey passed in commondat-tabdats table (e.g. 0 gives summary) ;; (define (dboard:common-get-tabdat commondat #!key (tab-num #f)) - (hash-table-ref/default - (dboard:commondat-tabdats commondat) - (or tab-num (dboard:commondat-curr-tab-num commondat)) ;; tab-num value is curr-tab-num value in passed commondat - #f)) + (let* ((tnum (or tab-num + (dboard:commondat-curr-tab-num commondat) + 0)) ;; tab-num value is curr-tab-num value in passed commondat + (ht (dboard:commondat-tabdats commondat)) + (res (hash-table-ref/default ht tnum #f))) + (or res + (let ((new-tabdat (dboard:tabdat-make-data))) + (hash-table-set! ht tnum new-tabdat) + new-tabdat)))) ;; RA => sets the tabdat passed to the hashkey at commondat:tabdats hash table ;; (define (dboard:common-set-tabdat! commondat tabnum tabdat) (hash-table-set! @@ -1934,20 +1939,20 @@ exn (begin (print-call-chain) (debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn)) (debug:print 0 *default-log-port* "ERROR: failed call procedure \"" updater - "\", with; tabnum=" tabnum ", view-name=" view-name + "\", with; tabnum=" tab-num ", view-name=" view-name ", and views-cfgdat and megatest configdat as parameters. To debug try loading in the repl: megatest -repl") (set! success #f)) (debug:print 4 *default-log-port* "Running updater for tab " view-name " with proc " updater " and tab-num: " tab-num) ((eval (string->symbol updater)) commondat tabs tab-num view-name views-cfgdat *configdat*))) tab-num: tab-num)) - (if success - (begin - ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) - (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) + ;;(if success + ;; (begin + ;; ;; (iup:attribute-set! tabs (conc "TABTITLE" tab-num) view-name) + ;; (dboard:common-set-tabdat! commondat tab-num (dboard:tabdat-make-data)))) result-child)) (define (dboard:runs-summary-buttons-updater tabdat) @@ -2723,11 +2728,11 @@ (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) -(iup:attribute-set! *tim* "TIME" 300 ) +(iup:attribute-set! *tim* "TIME" (or (configf:lookup *configdat* "dashboard" "poll-interval") "1000")) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) (define (dashboard:recalc modtime please-update-buttons last-db-update-time) Index: db.scm ================================================================== --- db.scm +++ db.scm @@ -210,46 +210,61 @@ ;; ;;(define *db-open-mutex* (make-mutex)) (define (db:lock-create-open fname initproc) (let* ((parent-dir (or (pathname-directory fname)(current-directory))) ;; no parent? go local + (raw-fname (pathname-file fname)) (dir-writable (file-write-access? parent-dir)) (file-exists (file-exists? fname)) (file-write (if file-exists (file-write-access? fname) dir-writable ))) ;;(mutex-lock! *db-open-mutex*) ;; tried this mutex, not clear it helped. (if file-write ;; dir-writable (condition-case - (let ((db (sqlite3:open-database fname))) - (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) - (sqlite3:execute db "PRAGMA synchronous = 0;") - (if (not file-exists) - (begin - (if (and (configf:lookup *configdat* "setup" "use-wal") - (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp - (sqlite3:execute db "PRAGMA journal_mode=WAL;") - (print "Creating " fname " in NON-WAL mode.")) - (initproc db))) - db) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) - + (let* ((lockfname (conc fname ".lock")) + (readyfname (conc parent-dir "/.ready-" raw-fname)) + (readyexists (file-exists? readyfname))) + (if (not readyexists) + (common:simple-file-lock-and-wait lockfname)) + (let ((db (sqlite3:open-database fname))) + (sqlite3:set-busy-handler! db (make-busy-timeout 136000)) + (sqlite3:execute db "PRAGMA synchronous = 0;") + (if (not file-exists) + (begin + (if (and (configf:lookup *configdat* "setup" "use-wal") + (string-match "^/tmp/.*" fname)) ;; this is a file in /tmp + (sqlite3:execute db "PRAGMA journal_mode=WAL;") + (print "Creating " fname " in NON-WAL mode.")) + (initproc db))) + (if (not readyexists) + (begin + (common:simple-file-release-lock lockfname) + (with-output-to-file + readyfname + (lambda () + (print "Ready at " + (seconds->year-work-week/day-time + (current-seconds))))))) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + (condition-case - (begin - (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) - (let ((db (sqlite3:open-database fname))) - ;;(mutex-unlock! *db-open-mutex*) - db)) - (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) - (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) - (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) - (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) - (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) + (begin + (debug:print 2 *default-log-port* "WARNING: opening db in non-writable dir " fname) + (let ((db (sqlite3:open-database fname))) + ;;(mutex-unlock! *db-open-mutex*) + db)) + (exn (io-error) (debug:print 0 *default-log-port* "ERROR: i/o error with " fname ". Check permissions, disk space etc. and try again.")) + (exn (corrupt) (debug:print 0 *default-log-port* "ERROR: database " fname " is corrupt. Repair it to proceed.")) + (exn (busy) (debug:print 0 *default-log-port* "ERROR: database " fname " is locked. Try copying to another location, remove original and copy back.")) + (exn (permission)(debug:print 0 *default-log-port* "ERROR: database " fname " has some permissions problem.")) + (exn () (debug:print 0 *default-log-port* "ERROR: Unknown error with database " fname " message: " ((condition-property-accessor 'exn 'message) exn)))) ))) @@ -299,16 +314,16 @@ (if (stack? tmpdb-stack) (db:get-db tmpdb-stack) ;; get previously opened db (will create new db handle if all in the stack are already used (let* ((dbpath (db:dbfile-path )) ;; path to tmp db area (dbexists (file-exists? dbpath)) (tmpdbfname (conc dbpath "/megatest.db")) - (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) - (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) + (dbfexists (file-exists? tmpdbfname)) ;; (conc dbpath "/megatest.db"))) (mtdbexists (file-exists? (conc *toppath* "/megatest.db"))) + (mtdb (db:open-megatest-db)) (mtdbpath (db:dbdat-get-path mtdb)) - + (tmpdb (db:open-megatest-db path: dbpath)) ;; lock-create-open dbpath db:initialize-main-db)) (refndb (db:open-megatest-db path: dbpath name: "megatest_ref.db")) (write-access (file-write-access? mtdbpath)) (mtdbmodtime (if mtdbexists (common:lazy-sqlite-db-modification-time mtdbpath) #f)) (tmpdbmodtime (if dbfexists (common:lazy-sqlite-db-modification-time tmpdbfname) #f)) (modtimedelta (and mtdbmodtime tmpdbmodtime (- mtdbmodtime tmpdbmodtime)))) @@ -370,11 +385,12 @@ (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) - (db:initialize-run-id-db db)))) + ;;(db:initialize-run-id-db db) + ))) (write-access (file-write-access? dbpath))) (debug:print-info 13 *default-log-port* "db:open-megatest-db "dbpath) (if (and dbexists (not write-access)) (set! *db-write-access* #f)) (cons db dbpath))) @@ -1200,21 +1216,21 @@ CONSTRAINT metadat_constraint UNIQUE (var));") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS access_log (id INTEGER PRIMARY KEY, user TEXT, accessed TIMESTAMP, args TEXT);") ;; Must do this *after* running patch db !! No more. ;; cannot use db:set-var since it will deadlock, hardwire the code here (sqlite3:execute db "INSERT OR REPLACE INTO metadat (var,val) VALUES (?,?);" "MEGATEST_VERSION" (common:version-signature)) - (debug:print-info 11 *default-log-port* "db:initialize END"))))) - -;;====================================================================== -;; R U N S P E C I F I C D B -;;====================================================================== - -(define (db:initialize-run-id-db db) - (sqlite3:with-transaction - db - (lambda () - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests + (debug:print-info 11 *default-log-port* "db:initialize END") ;; )))) + + ;;====================================================================== + ;; R U N S P E C I F I C D B + ;;====================================================================== + + ;; (define (db:initialize-run-id-db db) + ;; (sqlite3:with-transaction + ;; db + ;; (lambda () + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS tests (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, @@ -1234,18 +1250,18 @@ fail_count INTEGER DEFAULT 0, pass_count INTEGER DEFAULT 0, archived INTEGER DEFAULT 0, -- 0=no, > 1=archive block id where test data can be found last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT testsconstraint UNIQUE (run_id, testname, item_path));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS tests_index ON tests (run_id, testname, item_path, uname);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_tests_trigger AFTER UPDATE ON tests FOR EACH ROW BEGIN UPDATE tests SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_steps (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', @@ -1252,18 +1268,18 @@ event_time TIMESTAMP, comment TEXT DEFAULT '', logfile TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_steps_constraint UNIQUE (test_id,stepname,state));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS teststeps_index ON tests (run_id, testname, item_path);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_teststeps_trigger AFTER UPDATE ON test_steps FOR EACH ROW BEGIN UPDATE test_steps SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_data (id INTEGER PRIMARY KEY, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, @@ -1272,34 +1288,34 @@ comment TEXT DEFAULT '', status TEXT DEFAULT 'n/a', type TEXT DEFAULT '', last_update INTEGER DEFAULT (strftime('%s','now')), CONSTRAINT test_data_constraint UNIQUE (test_id,category,variable));") - (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") - (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data + (sqlite3:execute db "CREATE INDEX IF NOT EXISTS test_data_index ON test_data (test_id);") + (sqlite3:execute db "CREATE TRIGGER IF NOT EXISTS update_test_data_trigger AFTER UPDATE ON test_data FOR EACH ROW BEGIN UPDATE test_data SET last_update=(strftime('%s','now')) WHERE id=old.id; END;") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS test_rundat ( id INTEGER PRIMARY KEY, test_id INTEGER, update_time TIMESTAMP, cpuload INTEGER DEFAULT -1, diskfree INTEGER DEFAULT -1, diskusage INTGER DEFAULT -1, run_duration INTEGER DEFAULT 0);") - (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( + (sqlite3:execute db "CREATE TABLE IF NOT EXISTS archives ( id INTEGER PRIMARY KEY, test_id INTEGER, state TEXT DEFAULT 'new', status TEXT DEFAULT 'n/a', archive_type TEXT DEFAULT 'bup', du INTEGER, archive_path TEXT);"))) - db) + db)) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== @@ -2238,11 +2254,11 @@ (define (db:get-run-info dbstruct run-id) ;;(if (hash-table-ref/default *run-info-cache* run-id #f) ;; (hash-table-ref *run-info-cache* run-id) (let* ((res (vector #f #f #f #f)) (keys (db:get-keys dbstruct)) - (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count")) ;; "area_id")) + (remfields (list "id" "runname" "state" "status" "owner" "event_time" "comment" "fail_count" "pass_count" "contour")) ;; "area_id")) (header (append keys remfields)) (keystr (conc (keys->keystr keys) "," (string-intersperse remfields ",")))) (debug:print-info 11 *default-log-port* "db:get-run-info run-id: " run-id " header: " header " keystr: " keystr) (db:with-db @@ -3307,11 +3323,11 @@ (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction - (db:test-set-state-status db run-id test-id state status comment) + (db:test-set-state-status db run-id test-id state status comment) ;; this call sets the item state/status (if (not (equal? item-path "")) ;; only roll up IF incoming test is an item (let* ((state-status-counts (db:get-all-state-status-counts-for-test dbstruct run-id test-name item-path)) ;; item-path is used to exclude current state/status of THIS test (running (length (filter (lambda (x) (member (dbr:counts-state x) *common:running-states*)) state-status-counts))) @@ -3318,26 +3334,39 @@ (bad-not-started (length (filter (lambda (x) (and (equal? (dbr:counts-state x) "NOT_STARTED") (not (member (dbr:counts-status x) *common:not-started-ok-statuses*)))) state-status-counts))) - (all-curr-states (common:special-sort ;; worst -> best (sort of) - (delete-duplicates - (cons state (map dbr:counts-state state-status-counts))) - *common:std-states* >)) - (all-curr-statuses (common:special-sort ;; worst -> best - (delete-duplicates - (cons status (map dbr:counts-status state-status-counts))) - *common:std-statuses* >)) - (newstate (if (> running 0) - "RUNNING" - (if (> bad-not-started 0) - "COMPLETED" - (car all-curr-states)))) - (newstatus (if (> bad-not-started 0) - "CHECK" - (car all-curr-statuses)))) + ;; (non-completes (filter (lambda (x) + ;; (not (equal? (dbr:counts-state x) "COMPLETED"))) + ;; state-status-counts)) + (all-curr-states (common:special-sort ;; worst -> best (sort of) + (delete-duplicates + (cons state (map dbr:counts-state state-status-counts))) + *common:std-states* >)) + (all-curr-statuses (common:special-sort ;; worst -> best + (delete-duplicates + (cons status (map dbr:counts-status state-status-counts))) + *common:std-statuses* >)) + (non-completes (filter (lambda (x) + (not (equal? x "COMPLETED"))) + all-curr-states)) + (newstate (cond + ((> (length non-completes) 0) ;; + (car non-completes)) ;; (remove (lambda (x)(equal? "COMPLETED" x)) all-curr-states))) + (else + (car all-curr-states)))) + ;; (if (> running 0) + ;; "RUNNING" + ;; (if (> bad-not-started 0) + ;; "COMPLETED" + ;; (car all-curr-states)))) + (newstatus (if (> bad-not-started 0) + "CHECK" + (car all-curr-statuses)))) + ;; (print "bad-not-supported: " bad-not-support " all-curr-states: " all-curr-states " all-curr-statuses: " all-curr-states) + ;; " newstate: " newstate " newstatus: " newstatus) ;; NB// Pass the db so it is part of the transaction (db:test-set-state-status db run-id tl-test-id newstate newstatus #f))))))) (mutex-unlock! *db-transaction-mutex*) (if (and test-id state status (equal? status "AUTO")) (db:test-data-rollup dbstruct run-id test-id status)) ADDED gentargets.sh Index: gentargets.sh ================================================================== --- /dev/null +++ gentargets.sh @@ -0,0 +1,6 @@ +#!/bin/bash + +echo '[v1.63/tip/dev]' +echo 'x 1' +echo '[v1.64/tip/dev]' +echo 'x 1' Index: launch.scm ================================================================== --- launch.scm +++ launch.scm @@ -1,7 +1,7 @@ -;; Copyright 2006-2013, 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 @@ -399,15 +399,17 @@ (begin (thread-sleep! 3) ;; (+ 3 (random 6))) ;; add some jitter to the call home time to spread out the db accesses (if (hash-table-ref/default misc-flags 'keep-going #f) ;; keep originals for cpu-load and disk-free unless they change more than the allowed delta (loop (calc-minutes) (or new-cpu-load cpu-load) (or new-disk-free disk-free))))))) (tests:update-central-meta-info run-id test-id (get-cpu-load) (get-df (current-directory))(calc-minutes) #f #f))) ;; NOTE: Checking twice for keep-going is intentional + (define (launch:execute encoded-cmd) (let* ((cmdinfo (common:read-encoded-string encoded-cmd)) (tconfigreg #f)) (setenv "MT_CMDINFO" encoded-cmd) + ;;(bb-check-path msg: "launch:execute incoming") (if (list? cmdinfo) ;; ((testpath /tmp/mrwellan/jazzmind/src/example_run/tests/sqlitespeed) ;; (test-name sqlitespeed) (runscript runscript.rb) (db-host localhost) (run-id 1)) (let* ((testpath (assoc/default 'testpath cmdinfo)) ;; testpath is the test spec area (top-path (assoc/default 'toppath cmdinfo)) (work-area (assoc/default 'work-area cmdinfo)) ;; work-area is the test run area @@ -591,10 +593,11 @@ (begin (setenv var (config:eval-string-in-environment val))) ;; val) (debug:print-error 0 *default-log-port* "bad variable spec, " var "=" val)))) (configf:get-section rconfig section))) (list "default" target))) + ;;(bb-check-path msg: "launch:execute post block 1") ;; NFS might not have propagated the directory meta data to the run host - give it time if needed (let loop ((count 0)) (if (or (file-exists? work-area) (> count 10)) @@ -601,11 +604,11 @@ (change-directory work-area) (begin (debug:print 0 *default-log-port* "INFO: Not starting job yet - directory " work-area " not found") (thread-sleep! 10) (loop (+ count 1))))) - + ;;(bb-check-path msg: "launch:execute post block 1.5") ;; (change-directory work-area) (set! keyvals (keys:target->keyval keys target)) ;; apply pre-overrides before other variables. The pre-override vars must not ;; clobbers things from the official sources such as megatest.config and runconfigs.config (if (string? set-vars) @@ -617,10 +620,11 @@ (let ((var (car varval)) (val (cadr varval))) (debug:print 1 *default-log-port* "Adding pre-var/val " var " = " val " to the environment") (setenv var val))))) varpairs))) + ;;(bb-check-path msg: "launch:execute post block 2") (for-each (lambda (varval) (let ((var (car varval)) (val (cadr varval))) (if val @@ -636,22 +640,28 @@ (list "MT_RUNNAME" runname) (list "MT_MEGATEST" megatest) (list "MT_TARGET" target) (list "MT_LINKTREE" (common:get-linktree)) ;; (configf:lookup *configdat* "setup" "linktree")) (list "MT_TESTSUITENAME" (common:get-testsuite-name)))) + ;;(bb-check-path msg: "launch:execute post block 3") (if mt-bindir-path (setenv "PATH" (conc (getenv "PATH") ":" mt-bindir-path))) + ;;(bb-check-path msg: "launch:execute post block 4") ;; (change-directory top-path) ;; Can setup as client for server mode now ;; (client:setup) ;; environment overrides are done *before* the remaining critical envars. (alist->env-vars env-ovrd) + ;;(bb-check-path msg: "launch:execute post block 41") (runs:set-megatest-env-vars run-id inkeys: keys inkeyvals: keyvals) + ;;(bb-check-path msg: "launch:execute post block 42") (set-item-env-vars itemdat) + ;;(bb-check-path msg: "launch:execute post block 43") (save-environment-as-files "megatest") + ;;(bb-check-path msg: "launch:execute post block 44") ;; open-run-close not needed for test-set-meta-info ;; (tests:set-full-meta-info #f test-id run-id 0 work-area) ;; (tests:set-full-meta-info test-id run-id 0 work-area) (tests:set-full-meta-info #f test-id run-id 0 work-area 10) @@ -762,11 +772,12 @@ (targfile (conc fulldir "/.megatest.cfg-" megatest-version "-" megatest-fossil-hash)) (rconfig (conc fulldir "/.runconfig." megatest-version "-" megatest-fossil-hash))) (if (file-exists? rconfig) ;; only cache megatest.config AFTER runconfigs has been cached (begin (debug:print-info 0 *default-log-port* "Caching megatest.config in " tmpfile) - (configf:write-alist *configdat* tmpfile) + (if (not (common:in-running-test?)) + (configf:write-alist *configdat* tmpfile)) (system (conc "ln -sf " tmpfile " " targfile)))) ))) (debug:print-info 1 *default-log-port* "No linktree yet, no caching configs."))))) @@ -795,25 +806,31 @@ *toppath*) (let ((res (launch:setup-body force: force areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) -(define (launch:setup-body #!key (force #f) (areapath #f)) - (if (and (eq? *configstatus* 'fulldata) *toppath*) ;; no need to reprocess +(define (launch:setup-body #!key (force-reread #f) (areapath #f)) + (if (and (eq? *configstatus* 'fulldata) + *toppath* + (not force-reread)) ;; no need to reprocess *toppath* ;; return toppath (let* ((use-cache (common:use-cache?)) (toppath (or *toppath* areapath (getenv "MT_RUN_AREA_HOME"))) ;; preserve toppath + (runname (common:args-get-runname)) (target (common:args-get-target)) (linktree (common:get-linktree)) (contour #f) ;; NOT READY FOR THIS (args:get-arg "-contour")) (sections (if target (list "default" target) #f)) ;; for runconfigs (mtconfig (or (args:get-arg "-config") "megatest.config")) ;; allow overriding megatest.config - (rundir (if (and runname target linktree)(conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) #f)) + (rundir (if (and runname target linktree) + (conc linktree (if contour (conc "/" contour) "") "/" target "/" runname) + #f)) + (mtcachef (and rundir (conc rundir "/" ".megatest.cfg-" megatest-version "-" megatest-fossil-hash))) (rccachef (and rundir (conc rundir "/" ".runconfigs.cfg-" megatest-version "-" megatest-fossil-hash))) - (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir)))) + (cancreate (and rundir (common:file-exists? rundir)(file-write-access? rundir) (not (common:in-running-test?))))) ;; (cxt (hash-table-ref/default *contexts* toppath #f))) ;; create our cxt for this area if it doesn't already exist ;; (if (not cxt)(hash-table-set! *contexts* toppath (make-cxt))) 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.6402) +(define megatest-version 1.6403) Index: megatest.config ================================================================== --- megatest.config +++ megatest.config @@ -1,16 +1,22 @@ +[fields] +a text +b text +c text + [setup] pktsdirs /tmp/pkts /some/other/source [areas] # path-to-area map-target-script(future, optional) fullrun path=tests/fullrun # targtrans is name of scheme proc stored in .mtutil.scm, which lives in PWD where mtutil is run -ext-tests path=ext-tests; targtrans=prefix-contour; +# 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 +full areas=fullrun,ext-tests; selector=MAXPATT/ all areas=fullrun,ext-tests snazy areas=%; selector=QUICKPATT/ Index: megatest.scm ================================================================== --- megatest.scm +++ megatest.scm @@ -282,16 +282,16 @@ "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" + "-prefix-target" "-src-target" "-src-runname" "-diff-email" - "-sync-to" - "-prefix-target" + "-sync-to" "-pgsync" "-diff-html" ) (list "-h" "-help" "--help" "-manual" @@ -311,10 +311,11 @@ "-rerun-all" "-clean-cache" "-no-cache" "-cache-db" "-use-db-cache" + "-prepend-contour" ;; misc "-repl" "-lock" "-unlock" "-list-servers" @@ -857,11 +858,12 @@ (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin - (configf:write-alist data cfgf) + (if (not (common:in-running-test?)) + (configf:write-alist data cfgf)) ;; force re-read of megatest.config - this resolves circular references between megatest.config (launch:setup force: #t) (launch:cache-config))) ;; we can safely cache megatest.config since we have a valid runconfig data)))) Index: mtut.scm ================================================================== --- mtut.scm +++ mtut.scm @@ -28,14 +28,10 @@ (require-library stml) (define *target-mappers* (make-hash-table)) ;; '()) (define *runname-mappers* (make-hash-table)) ;; '()) -(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc"))) - (if (file-exists? debugcontrolf) - (load debugcontrolf))) - ;; 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? @@ -393,11 +389,13 @@ (let* ((sched (cond ((vector? sched-in)(local-time->seconds sched-in)) ;; we recieved a time ((number? sched-in) sched-in) (else (current-seconds)))) (args-data (if args-alist - args-alist + (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 'U (current-user-name) 'D sched) @@ -883,10 +881,14 @@ (define (get-pkts-dir mtconf) (let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))) pktsdir)) +(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.mtutilrc"))) + (if (file-exists? debugcontrolf) + (load debugcontrolf))) + (if *action* (case (string->symbol *action*) ((run remove rerun set-ss archive kill) (let* ((mtconfdat (simple-setup (args:get-arg "-start-dir"))) (mtconf (car mtconfdat)) @@ -937,11 +939,10 @@ ;; (if (get-environment-variable "HTTP_HOST") (begin (stml:main #f) (exit))) - (if (or (args:get-arg "-repl") (args:get-arg "-load")) (begin (import extras) ;; might not be needed Index: newdashboard.scm ================================================================== --- newdashboard.scm +++ newdashboard.scm @@ -29,19 +29,19 @@ (use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct (prefix dbi dbi:)) (declare (uses common)) +(declare (uses megatest-version)) +(declare (uses margs)) -;; (declare (uses margs)) ;; (declare (uses launch)) -;; (declare (uses megatest-version)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses server)) ;; (declare (uses synchash)) -;; (declare (uses dcommon)) +(declare (uses dcommon)) ;; (declare (uses tree)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") @@ -122,18 +122,130 @@ (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (update-search x val) (hash-table-set! *searchpatts* x val)) + + +;; data for each specific tab goes here +;; +(defstruct dboard:tabdat + ;; runs + ((allruns '()) : list) ;; list of dboard:rundat records + ((allruns-by-id (make-hash-table)) : hash-table) ;; hash of run-id -> dboard:rundat records + ((done-runs '()) : list) ;; list of runs already drawn + ((not-done-runs '()) : list) ;; list of runs not yet drawn + (header #f) ;; header for decoding the run records + (keys #f) ;; keys for this run (i.e. target components) + ((numruns (string->number (or (args:get-arg "-cols") "10"))) : number) ;; + ((tot-runs 0) : number) + ((last-data-update 0) : number) ;; last time the data in allruns was updated + ((last-runs-update 0) : number) ;; last time we pulled the runs info to update the tree + (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects + ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id + ((last-test-dat (make-hash-table)) : hash-table) ;; cache last tests dat by run-id + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files + + ;; Runs view + ((buttondat (make-hash-table)) : hash-table) ;; + ((item-test-names '()) : list) ;; list of itemized tests + ((run-keys (make-hash-table)) : hash-table) + (runs-matrix #f) ;; used in newdashboard + ((start-run-offset 0) : number) ;; left-right slider value + ((start-test-offset 0) : number) ;; up-down slider value + ((runs-btn-height (or (configf:lookup *configdat* "dashboard" "btn-height") "x16")) : string) ;; was 12 + ((runs-btn-fontsz (or (configf:lookup *configdat* "dashboard" "btn-fontsz") "10")) : string) ;; was 8 + ((runs-cell-width (or (configf:lookup *configdat* "dashboard" "cell-width") "60")) : string) ;; was 50 + ((all-test-names '()) : list) + + ;; Canvas and drawing data + (cnv #f) + (cnv-obj #f) + (drawing #f) + ((run-start-row 0) : number) + ((max-row 0) : number) + ((running-layout #f) : boolean) + (originx #f) + (originy #f) + ((layout-update-ok #t) : boolean) + ((compact-layout #t) : boolean) + + ;; Run times layout + ;; (graph-button-box #f) ;; RA => Think it is not referenced anywhere + (graph-matrix #f) + ((graph-matrix-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru graph name info + ((graph-cell-table (make-hash-table)) : hash-table) ;; graph-dats referenced thru matrix cell info + ((graph-matrix-row 1) : number) + ((graph-matrix-col 1) : number) + + ;; Controls used to launch runs etc. + ((command "") : string) ;; for run control this is the command being built up + (command-tb #f) ;; widget for the type of command; run, remove-runs etc. + (test-patterns-textbox #f) ;; text box widget for editing a list of test patterns + (key-listboxes #f) + (key-lbs #f) + run-name ;; from run name setting widget + states ;; states for -state s1,s2 ... + statuses ;; statuses for -status s1,s2 ... + + ;; Selector variables + curr-run-id ;; current row to display in Run summary view + prev-run-id ;; previous runid selected before current runid was selected (used in xor-two-runs runs summary mode + curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard + ((filters-changed #t) : boolean) ;; to indicate that the user changed filters for this tab + ((last-filter-str "") : string) ;; conc the target runname and testpatt for a signature of changed filters + ((hide-empty-runs #f) : boolean) + ((hide-not-hide #t) : boolean) ;; toggle for hide/not hide empty runs + (hide-not-hide-button #f) + ((searchpatts (make-hash-table)) : hash-table) ;; + ((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control + ((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f + (target #f) + (test-patts #f) + + ;; db info to file the .db files for the area + (access-mode (db:get-access-mode)) ;; use cached db or not + (dbdir #f) + (dbfpath #f) + (dbkeys #f) + ((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp + (monitor-db-path #f) ;; where to find monitor.db + ro ;; is the database read-only? + + ;; tests data + ((num-tests 10) : number) ;; total number of tests to show (used in the old runs display) + + ;; runs tree + ((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id + (runs-tree #f) + ((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?) + + ;; tab data + ((view-changed #t) : boolean) + ((xadj 0) : number) ;; x slider number (if using canvas) + ((yadj 0) : number) ;; y slider number (if using canvas) + ;; runs-summary tab state + ((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list) + ((runs-summary-mode-buttons '()) : list) + ((runs-summary-mode 'one-run) : symbol) + ((runs-summary-mode-change-callbacks '()) : list) + (runs-summary-source-runname-label #f) + (runs-summary-dest-runname-label #f) + ;; runs summary view + + tests-tree ;; used in newdashboard + ) + + ;; mtest is actually the megatest.config file ;; (define (mtest toppath window-id) (let* ((curr-row-num 0) - (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) - (keys-matrix (dcommon:keys-matrix rawconfig)) - (setup-matrix (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) + ;; (rawconfig (read-config (conc toppath "/megatest.config") #f 'return-string)) + (keys-matrix (iup:matrix)) ;; (dcommon:keys-matrix rawconfig)) + (setup-matrix (iup:matrix)) ;; (dcommon:section-matrix rawconfig "setup" "Varname" "Value")) (jobtools-matrix (iup:matrix #:expand "YES" #:numcol 1 #:numlin 5 #:numcol-visible 1 @@ -170,13 +282,13 @@ (lambda (mat fname) (set! curr-row-num 1) (for-each (lambda (var) (iup:attribute-set! mat (conc curr-row-num ":0") var) - (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) + ;; (iup:attribute-set! mat (conc curr-row-num ":1") (config-lookup rawconfig fname var)) (set! curr-row-num (+ curr-row-num 1))) - (configf:section-vars rawconfig fname))) + '()));; (configf:section-vars rawconfig fname))) (list setup-matrix jobtools-matrix validvals-matrix envovrd-matrix disks-matrix) (list "setup" "jobtools" "validvalues" "env-override" "disks")) (for-each (lambda (mat) @@ -341,11 +453,11 @@ #:numlin-visible 8)) (updater (lambda (testdat) (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix)))) ;; Set the updater in updaters - (hash-table-set! (dboard:data-updaters *data*) window-id updater) + ;; (hash-table-set! (dboard:data-updaters *data*) window-id updater) ;; (for-each (lambda (mat) ;; (iup:attribute-set! mat "0:1" "Value") ;; (iup:attribute-set! mat "0:0" "Var") @@ -442,27 +554,27 @@ #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) (test-id (tree-path->test-id (cdr run-path)))) - (if test-id - (hash-table-set! (dboard:data-curr-test-ids *data*) - window-id test-id)) + ;; (if test-id + ;; (hash-table-set! (dboard:data-curr-test-ids *data*) + ;; window-id test-id)) (print "path: " (tree:node->path obj id) " test-id: " test-id)))))) (iup:attribute-set! tb "VALUE" "0") (iup:attribute-set! tb "NAME" "Runs") ;;(iup:attribute-set! tb "ADDEXPANDED" "NO") - (dboard:data-tests-tree-set! *data* tb) + ;; (dboard:data-tests-tree-set! *data* tb) tb) (test-panel window-id))) ;; The function to update the fields in the test view panel (define (test-update window-id testdat run-info-matrix test-info-matrix test-run-matrix meta-dat-matrix steps-matrix data-matrix) ;; get test-id ;; then get test record (if testdat - (let* ((test-id (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) + (let* ((test-id 0) ;; (hash-table-ref/default (dboard:data-curr-test-ids *data*) window-id #f)) (test-data (hash-table-ref/default testdat test-id #f)) (run-id (db:test-get-run_id test-data)) (targ/runname (hash-table-ref/default (dboard:data-run-keys *data*) run-id '())) @@ -558,11 +670,11 @@ (print "obj: " obj " lin: " lin " col: " col " status: " status))))) (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! runs-matrix "WIDTH0" "100") - (dboard:data-runs-matrix-set! *data* runs-matrix) + ;; (dboard:data-runs-matrix-set! *data* runs-matrix) (iup:hbox (iup:frame #:title "Runs browser" (iup:vbox runs-matrix))))) @@ -598,20 +710,20 @@ (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) - (keys (db:get-keys dbstruct)) + (keys '()) ;; (db:get-keys dbstruct)) (runname "%") (testpatt "%") - (keypatts (map (lambda (k)(list k "%")) keys)) - (states '()) + (keypatts '()) ;; (map (lambda (k)(list k "%")) keys)) + (states '()) (statuses '()) (nextmintime (current-milliseconds)) (my-window-id *current-window-id*)) (set! *current-window-id* (+ 1 *current-window-id*)) - (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application + ;; (dboard:data-runs-set! *data* data) ;; make this data available to the rest of the application (iup:show (main-panel my-window-id)) ;; Yes, running iup:show will pop up a new panel ;; (iup:show (main-panel my-window-id)) (iup:callback-set! *tim* "ACTION_CB" @@ -624,8 +736,8 @@ (endtime (current-milliseconds))) (set! nextmintime (+ endtime (* 2 (- endtime starttime)))) (debug:print 11 *default-log-port* "CHANGE(S): " (car changes) "...")) (debug:print-info 11 *default-log-port* "Server overloaded")))))) -(dboard:data-updaters-set! *data* (make-hash-table)) -(newdashboard *dbstruct-local*) +;; (dboard:data-updaters-set! *data* (make-hash-table)) +(newdashboard #f) ;; *dbstruct-local*) (iup:main-loop) Index: rmt.scm ================================================================== --- rmt.scm +++ rmt.scm @@ -673,10 +673,13 @@ (rmt:send-receive 'get-main-run-stats #f (list run-id))) (define (rmt:get-var varname) (rmt:send-receive 'get-var #f (list varname))) +(define (rmt:del-var varname) + (rmt:send-receive 'del-var #f (list varname))) + (define (rmt:set-var varname value) (rmt:send-receive 'set-var #f (list varname value))) ;;====================================================================== ;; M U L T I R U N Q U E R I E S Index: runconfigs.config ================================================================== --- runconfigs.config +++ runconfigs.config @@ -9,13 +9,21 @@ # 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 + +[scriptinc ./gentargets.sh #{getenv USER}] +# [v1.23/45/67] # tip will be replaced with hashkey? -[v1.63/tip/dev] + +# [%/%/%] doesn't work + +[/.*/] + +# [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 Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -51,10 +51,11 @@ waitons testmode newtal itemmaps prereqs-not-met) ;; set up needed environment variables given a run-id and optionally a target, itempath etc. ;; (define (runs:set-megatest-env-vars run-id #!key (inkeys #f)(inrunname #f)(inkeyvals #f)(intarget #f)(testname #f)(itempath #f)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars entry") (let* ((target (or intarget (common:args-get-target) (get-environment-variable "MT_TARGET"))) (keys (if inkeys inkeys (rmt:get-keys))) (keyvals (if inkeyvals inkeyvals (keys:target->keyval keys target))) @@ -74,19 +75,23 @@ (for-each (lambda (key) (hash-table-set! vals (car key) (cadr key))) keyvals))) ;; from the cached data set the vars + (hash-table-for-each vals (lambda (key val) (debug:print 2 *default-log-port* "setenv " key " " val) (safe-setenv key val))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1") + ;;(BB> "*env-vars-by-run-id*/runid("run-id" vals="(hash-table->alist vals)) + (if (not (get-environment-variable "MT_TARGET"))(setenv "MT_TARGET" target)) ;; we had a case where there was an exception generated by the hash-table-ref ;; due to *configdat* being #f Adding a handle and exit - (let fatal-loop ((count 0)) + (let fatal-loop ((count 0)) (handle-exceptions exn (let ((call-chain (get-call-chain)) (msg ((condition-property-accessor 'exn 'message) exn))) (if (< count 5) @@ -98,20 +103,23 @@ (debug:print 0 *default-log-port* "FATAL: *configdat* was inaccessible! This should never happen. Retried " count " times. Message: " msg) (debug:print 0 *default-log-port* "Call chain:") (with-output-to-port *default-log-port* (lambda ()(pp call-chain))) (exit 1)))) - (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 1.5") + (alist->env-vars (hash-table-ref/default *configdat* "env-override" '())))) ;;;; environment is tainted HERE in this let block. + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 2") ;; Lets use this as an opportunity to put MT_RUNNAME in the environment (let ((runname (if inrunname inrunname (rmt:get-run-name-from-id run-id)))) (if runname (setenv "MT_RUNNAME" runname) (debug:print-error 0 *default-log-port* "no value for runname for id " run-id))) (setenv "MT_RUN_AREA_HOME" *toppath*) ;; if a testname and itempath are available set the remaining appropriate variables (if testname (setenv "MT_TEST_NAME" testname)) (if itempath (setenv "MT_ITEMPATH" itempath)) + ;;(bb-check-path msg: "runs:set-megatest-env-vars block 3") (if (and testname link-tree) (setenv "MT_TEST_RUN_DIR" (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME") "/" (getenv "MT_TEST_NAME") Index: tasks.scm ================================================================== --- tasks.scm +++ tasks.scm @@ -614,25 +614,31 @@ (define (tasks:run-id->mtpg-run-id dbh cached-info run-id) (let* ((runs-ht (hash-table-ref cached-info 'runs)) (runinf (hash-table-ref/default runs-ht run-id #f))) (if runinf runinf ;; already cached - (let* ((keytarg (string-intersperse (rmt:get-keys) "/")) ;; e.g. version/iteration/platform - (spec-id (pgdb:get-ttype dbh keytarg)) - (target (if (and (args:get-arg "-sync-to") (args:get-arg "-prefix-target")) (set! target (conc (args:get-arg "-prefix-target") (rmt:get-target run-id))) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu - (run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > + (let* ((run-dat (rmt:get-run-info run-id)) ;; NOTE: get-run-info returns a vector < row header > (run-name (rmt:get-run-name-from-id run-id)) - (new-run-id (pgdb:get-run-id dbh spec-id target run-name)) (row (db:get-rows run-dat)) ;; yes, this returns a single row (header (db:get-header run-dat)) (state (db:get-value-by-header row header "state ")) (status (db:get-value-by-header row header "status")) (owner (db:get-value-by-header row header "owner")) (event-time (db:get-value-by-header row header "event_time")) (comment (db:get-value-by-header row header "comment")) (fail-count (db:get-value-by-header row header "fail_count")) (pass-count (db:get-value-by-header row header "pass_count")) + (contour (if (args:get-arg "-prepend-contour") (db:get-value-by-header row header "contour"))) + (keytarg (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) + (conc "MT_CONTOUR/MT_AREA/" (string-intersperse (rmt:get-keys) "/")) (string-intersperse (rmt:get-keys) "/"))) ;; e.g. version/iteration/platform + (target (if (or (args:get-arg "-prepend-contour") (args:get-arg "-prefix-target")) + (conc (or (args:get-arg "-prefix-target") (conc contour "/" (common:get-area-name) "/")) (rmt:get-target run-id)) (rmt:get-target run-id))) ;; e.g. v1.63/a3e1/ubuntu + (spec-id (pgdb:get-ttype dbh keytarg)) + (new-run-id (pgdb:get-run-id dbh spec-id target run-name)) + + + ;; (area-id (db:get-value-by-header row header "area_id)")) ) (if new-run-id (begin ;; let ((run-record (pgdb:get-run-info dbh new-run-id)) (hash-table-set! runs-ht run-id new-run-id) Index: tests.scm ================================================================== --- tests.scm +++ tests.scm @@ -1201,11 +1201,12 @@ (if (and testexists cache-file (file-write-access? cache-path)) (let ((tpath (conc cache-path "/.testconfig"))) (debug:print-info 1 *default-log-port* "Caching testconfig for " test-name " in " tpath) - (configf:write-alist tcfg tpath))) + (if (not (common:in-running-test?)) + (configf:write-alist tcfg tpath)))) tcfg)))))) ;; sort tests by priority and waiton ;; Move test specific stuff to a test unit FIXME one of these days (define (tests:sort-by-priority-and-waiton test-records) Index: utils/nbfake ================================================================== --- utils/nbfake +++ utils/nbfake @@ -4,10 +4,12 @@ # nbfake - capture command output in a logfile # # nbfake behavior can be changed by setting the following env vars: # NBFAKE_HOST SSH to $NBFAKE_HOST and run command # NBFAKE_LOG Logfile for nbfake output +# NB_WASH_GROUPS comma-separated list of groups to wash into +# NB_WASH_ENABLED must be set in order to enable wash groups # ############################################################################### if [[ -z "$@" ]]; then cat <<__EOF @@ -17,10 +19,12 @@ nbfake nbfake behavior can be changed by setting the following env vars: NBFAKE_HOST SSH to \$NBFAKE_HOST and run command NBFAKE_LOG Logfile for nbfake output + NB_WASH_GROUPS comma-separated list of groups to wash into + NB_WASH_ENABLED must be set in order to enable wash groups __EOF exit fi @@ -53,24 +57,31 @@ # Set default nbfake log if [[ -z "$MY_NBFAKE_LOG" ]]; then MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) fi + +# wash groups handling. Default is no action +WASHCMD="" +if [[ -n ${NB_WASH_ENABLED+1} && -n ${NB_WASH_GROUPS+1} ]]; then + grouplist=`echo $NB_WASH_GROUPS | tr ',' ' '` + WASHCMD="wash -q -n $grouplist -X" +fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG -# $* +# $WASHCMD $* #====================================================================== __EOF if [[ -z "$MY_NBFAKE_HOST" ]]; then # Run locally - sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &" + sh -c "cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &" else # run remotely - ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $* >> $MY_NBFAKE_LOG 2>&1 &\"" + ssh -X -n -f $MY_NBFAKE_HOST "sh -c \"cd $CURRWD;export DISPLAY=$DISPLAY; export PATH=$PATH; nohup $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi