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,45 @@
(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>=?)))
+
+(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 +353,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 0 *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
@@ -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)))
@@ -3326,18 +3342,28 @@
*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))))
+ (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 "running: " running " bad-not-started: " bad-not-started " all-curr-states: " all-curr-states " non-completes: " non-completes " state-status-counts: " state-status-counts
+ " 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
@@ -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,21 +593,22 @@
(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))
(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,27 @@
(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 411")
(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 42")
(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 +771,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 +805,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,19 @@
# 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]
+# [v1.23/45/67]
# tip will be replaced with hashkey?
-[v1.63/tip/dev]
+
+[/.*/]
+
+# [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,24 @@
(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))
+ (bb-check-path msg: "runs:set-megatest-env-vars block 1")
;; 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 +104,24 @@
(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