Changes In Branch v1.64-bb1 Through [91c7fb7326] Excluding Merge-Ins
This is equivalent to a diff from fd47a3e816 to 91c7fb7326
2017-04-06
| ||
14:19 | merging mainline Closed-Leaf check-in: b1b733f324 user: bjbarcla tags: v1.64-bb1 | |
14:17 | v1.64-bb1 check-in: 91c7fb7326 user: bjbarcla tags: v1.64-bb1 | |
11:51 | blah blah Closed-Leaf check-in: 45e3a1e3be user: bjbarcla tags: temp-branch-for-recovery | |
11:45 | Consolidating some stuff back on v1.64 check-in: a81649fabf user: mrwellan tags: v1.64, v1.6403 | |
2017-03-30
| ||
12:30 | v1.64-cache-issue check-in: e2ffc3801e user: bjbarcla tags: v1.64-envdebug | |
2017-03-29
| ||
11:03 | added unlock_db.sh to utils check-in: fd47a3e816 user: bjbarcla tags: v1.64 | |
10:50 | added utilities I developed on the side to assist in transition. Not functional yet in this area. check-in: 275dbf2c2e user: bjbarcla tags: v1.64 | |
Modified .mtutil.scm from [dcf82d5ea0] to [3e3e4527c3].
︙ | ︙ | |||
59 60 61 62 63 64 65 | (conc (seconds->wwdate (current-seconds)) next-letter)))) (hash-table-set! *runname-mappers* 'auto (lambda (target run-name area area-path reason contour mode-patt) "auto-eh")) | | | 59 60 61 62 63 64 65 66 67 | (conc (seconds->wwdate (current-seconds)) next-letter)))) (hash-table-set! *runname-mappers* 'auto (lambda (target run-name area area-path reason contour mode-patt) "auto-eh")) ;; (print "Got here!") |
Modified api.scm from [d7ff6e57f4] to [9ab20f89e3].
︙ | ︙ | |||
167 168 169 170 171 172 173 174 175 176 177 178 179 180 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((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)) ;; STEPS ((teststep-set-status!) (apply db:teststep-set-status! dbstruct params)) ;; TEST DATA ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) | > | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | ((register-run) (apply db:register-run dbstruct params)) ((set-tests-state-status) (apply db:set-tests-state-status dbstruct params)) ((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 ((test-data-rollup) (apply db:test-data-rollup dbstruct params)) ((csv->test-data) (apply db:csv->test-data dbstruct params)) |
︙ | ︙ |
Added cgisetup/css/pjhatwal-modal.css version [3c745bf116].
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 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 version [6530096b9d].
> > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 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"; }); }); |
Modified cgisetup/models/pgdb.scm from [1921a0ad10] to [6fd66727e0].
︙ | ︙ | |||
23 24 25 26 27 28 29 | ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; | | > > > | > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | ;; (import data-structures) ;; (import chicken) (use typed-records (prefix dbi dbi:)) ;; given a configdat lookup the connection info and open the db ;; (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)) (val (cadr parts))) (cons (string->symbol key) val)) |
︙ | ︙ | |||
165 166 167 168 169 170 171 | (dbi:get-rows dbh "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)) | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 | (dbi:get-rows dbh "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-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, 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 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 (lambda (ttype-dat) (let ((tt-id (vector-ref ttype-dat 0)) |
︙ | ︙ | |||
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 | (coldat (hash-table-ref/default data first #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data first newht) (set! coldat newht))) (hash-table-set! coldat rest run))) runs) data)) (define (pgdb:runs-to-hash runs ) (let* ((data (make-hash-table))) (for-each (lambda (run) (let* ((run-name (vector-ref run 0)) (test (conc (vector-ref run 1) ":" (vector-ref run 3))) (coldat (hash-table-ref/default data run-name #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data run-name newht) (set! coldat newht))) (hash-table-set! coldat test run))) runs) data)) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | (coldat (hash-table-ref/default data first #f))) (if (not coldat)(let ((newht (make-hash-table))) (hash-table-set! data first newht) (set! coldat newht))) (hash-table-set! coldat rest run))) runs) data)) ;; 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) (let* ((run-name (vector-ref run 0)) (test (conc (vector-ref run 1) ":" (vector-ref run 3))) (coldat (hash-table-ref/default data run-name #f))) (if (not coldat)(let ((newht (make-hash-table))) (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)) |
Modified cgisetup/pages/home_ctrl.scm from [cf27e7d669] to [e5b104a203].
︙ | ︙ | |||
23 24 25 26 27 28 29 | ;; (s:set! "row-or-col" (if (list? row-or-col) (string-intersperse row-or-col ",") row-or-col)) (s:set! "target-type" target-type) (s:set! "tfilter" target-filter) (s:set! "target" target) | | > > > > > > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | ;; (s:set! "row-or-col" (if (list? row-or-col) (string-intersperse row-or-col ",") row-or-col)) (s:set! "target-type" target-type) (s:set! "tfilter" target-filter) (s:set! "target" target) (s:set! "target-filter" target-filter))) ((filter2) (let ((tslice-select (s:get-input 'tslice-select)) (t-slice-filter (s:get-input 't-slice-filter))) ;; ;; s:set! is a page local var. Better than s:session-var-set! but still not a good idea. ;; (s:set! "tslice" tslice-select) (s:set! "t-slice-patt" t-slice-filter))) )) |
Modified cgisetup/pages/home_view.scm from [0d15bde503] to [4f70880903].
︙ | ︙ | |||
8 9 10 11 12 13 14 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) (ttypes (pgdb:get-target-types dbh)) | | > > > > > > > > > > < < > > | | > | > | | > > > > > > > > | > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > | | | | | > | | < < < < < < < < < < < < < < < < < < | | < < < | < < < | | | < | > > > > | > < < | > > | < < | > > > > > > > > > > > > > > > > > > > > > > > | > > | > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | ;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ;; PURPOSE. ;;====================================================================== (define (pages:home session db shared) (let* ((dbh (s:db)) (ttypes (pgdb:get-target-types dbh)) (selected (string->number (or (s:get "target-type") "-1"))) (target-slice (pgdb:get-distict-target-slice dbh)) (selected-slice (or (s:get "tslice") "")) (curr-trec (filter (lambda (x)(eq? selected (vector-ref x 0))) ttypes)) (curr-ttype (if (and selected (not (null? curr-trec))) (vector-ref (car curr-trec) 1) #f)) (all-parts (if curr-ttype (append (string-split curr-ttype "/") '("runname" "testname")) '())) (tfilter (or (s:get "target-filter") "%")) (tslice-filter (or (s:get "t-slice-patt") "")) (target-patt (if (or (equal? selected-slice "") (equal? tslice-filter "" )) "" (conc selected-slice "/" tslice-filter ))) (tab2-data (if (equal? target-patt "") `() (pgdb:get-all-run-stats-target-slice dbh target-patt))) (tab2-ordered-data (pgdb:coalesce-runs-by-slice tab2-data selected-slice)) (targets (pgdb:get-targets-of-type dbh selected tfilter)) (row-or-col (string-split (or (s:get "row-or-col") "") ",")) (all-data (if (and selected (not (eq? selected -1))) (pgdb:get-latest-run-stats-given-target dbh selected tfilter) '() ; (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#tabr2" 'method "post" (s:div 'class "col_12" (s:div 'class "col_6" (s:select (map (lambda (x) (if x (let ((tt-id (vector-ref x 0)) (ttype (vector-ref x 1))) (if (eq? tt-id selected) (list ttype tt-id ttype #t) (list ttype tt-id ttype #f))) (list "all" -1 "all" (eq? selected -1)))) (cons #f ttypes)) 'name 'target-type)) (s:div 'class "col_4" (s:input-preserve 'name "tfilter" 'placeholder "Filter targets")) (s:div 'class "col_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 " tfilter) ;; ;; A very basic display ;; (let* ((a-keys (pgdb:ordered-data->a-keys ordered-data)) (b-keys (pgdb:ordered-data->b-keys ordered-data a-keys))) ;; (c-keys (delete-duplicates b-keys))) (if #f ;; swap rows/cols (s:table (s:tr (s:td "")(map s:tr b-keys)) (map (lambda (row-key) (let ((subdat (hash-table-ref ordered-data row-key))) (s:tr (s:td row-key) (map (lambda (col-key) (s:td (let ((dat (hash-table-ref/default subdat col-key #f))) (s:td (if dat (list (vector-ref dat 0)(vector-ref dat 1)) ""))))) b-keys)))) a-keys)) (s:table 'class "striped" (s: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) (let ((val (let* ((ht (hash-table-ref/default ordered-data col-key #f))) (if ht (hash-table-ref/default ht row-key #f))))) (if val (let* ((total (vector-ref val 1)) (pass (vector-ref val 2)) (fail (vector-ref val 3)) (other (vector-ref val 4)) (id (vector-ref val 5)) (passper (round (* (/ pass total) 100))) (failper (- 100 passper)) (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 '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))))))) ))) |
Modified cgisetup/pages/index_ctrl.scm from [2db5974e1a] to [afbe8a90ae].
︙ | ︙ | |||
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 | #<<EOF <meta charset="UTF-8"> <meta name="viewport" content="width=device-width, initial-scale=1.0"/> <meta name="description" content="" /> <link rel="stylesheet" type="text/css" href="/css/kickstart.css" media="all" /> <!-- KICKSTART --> <link rel="stylesheet" type="text/css" href="/style.css" media="all" /> <!-- CUSTOM STYLES --> <link rel="icon" type="image/x-icon" href="/favicon.ico" /> <style type="text/css"> .column { /* border:1px solid red; */ padding:0px; } </style> EOF ) (define index:jquery (if #t | > > > > > > > > | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | #<<EOF <meta charset="UTF-8"> <meta name="viewport" content="width=device-width, initial-scale=1.0"/> <meta name="description" content="" /> <link rel="stylesheet" type="text/css" href="/css/kickstart.css" media="all" /> <!-- KICKSTART --> <link rel="stylesheet" type="text/css" href="/style.css" media="all" /> <!-- CUSTOM STYLES --> <link rel="stylesheet" type="text/css" href="/css/pjhatwal-modal.css" media="all" /> <!-- Modal --> <link rel="icon" type="image/x-icon" href="/favicon.ico" /> <style type="text/css"> .column { /* border:1px solid red; */ padding:0px; } a.white{ color:white; } th.heading{ text-align:-webkit-center; background:rgba(0, 0, 0, 0.21); } </style> EOF ) (define index:jquery (if #t |
︙ | ︙ | |||
54 55 56 57 58 59 60 61 62 63 | EOF )) (define index:javascript #<<EOF <script type="text/javascript" src="/js/prettify.js"></script> <!-- PRETTIFY --> <script type="text/javascript" src="/js/kickstart.js"></script> <!-- KICKSTART --> EOF ) | > | 62 63 64 65 66 67 68 69 70 71 72 | EOF )) (define index:javascript #<<EOF <script type="text/javascript" src="/js/prettify.js"></script> <!-- PRETTIFY --> <script type="text/javascript" src="/js/kickstart.js"></script> <!-- KICKSTART --> <script type="text/javascript" src="/js/pjhatwal-modal.js "></script> <!-- Modal --> EOF ) |
Modified cgisetup/pages/run_view.scm from [8edac034a0] to [7ccbd2143e].
︙ | ︙ | |||
13 14 15 16 17 18 19 | (target-param (s:get-param 'target)) (target1 (if (s:get "target") (s:get "target") (s:get-param 'target))) (target (if (equal? target1 #f) "%" (string-substitute "_x_" "/" target1 'all) | | > | | 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | (target-param (s:get-param 'target)) (target1 (if (s:get "target") (s:get "target") (s:get-param 'target))) (target (if (equal? target1 #f) "%" (string-substitute "_x_" "/" target1 'all) )) (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 "Run filter" (s:form |
︙ | ︙ | |||
62 63 64 65 66 67 68 | (if val (let* ((result (vector-ref val 2)) (test-id (vector-ref val 4)) (bg (if (equal? result "PASS") "green" "red"))) (s:td 'style (conc "background: " bg ) | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 | (if val (let* ((result (vector-ref val 2)) (test-id (vector-ref val 4)) (bg (if (equal? result "PASS") "green" "red"))) (s:td 'style (conc "background: " bg ) (s:a 'class "white" 'href (s:link-to "log" 'testid test-id) result))) (s:td "")))) a-keys))) b-keys))))))) |
Modified common.scm from [735742a8cc] to [d40a0cdfdd].
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | (if (and best (> bestsize minsize)) best #f))) ;; #f means no disk candidate found ;;====================================================================== ;; E N V I R O N M E N T V A R S ;;====================================================================== | > > > > > > | > > | | 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 | (if (and best (> bestsize minsize)) best #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") (lambda () (for-each (lambda (keyval) (let* ((key (car keyval)) (val (cdr keyval)) (delim (if (string-search whitesp val) "\"" ""))) |
︙ | ︙ | |||
2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 | (string-intersperse (map (lambda (x) (number->string x 16)) (map string->number (string-split instr))) "/")) (define (common:get-color-from-status status) (cond ((equal? status "PASS") "green") ((equal? status "FAIL") "red") ((equal? status "WARN") "orange") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") | > > > > > > > > > > > > > > > > > > | 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 | (string-intersperse (map (lambda (x) (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") ((equal? status "KILLED") "orange") ((equal? status "KILLREQ") "purple") |
︙ | ︙ |
Modified configf.scm from [e78af9bffb] to [df30172ca7].
︙ | ︙ | |||
661 662 663 664 665 666 667 | (handle-exceptions exn #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) | > | > > | | | > | | | | | | | | | | > > > > > > | | 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | (handle-exceptions exn #f (configf:alist->config (with-input-from-file fname read)))) (define (configf:write-alist cdat fname) (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 (lambda (section) (let ((section-name (car section)) |
︙ | ︙ |
Modified dashboard.scm from [749c4b1673] to [a14a45cd51].
︙ | ︙ | |||
148 149 150 151 152 153 154 | updating: #f hide-not-hide-tabs: #f )) ;; 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)) | | | | > > > > > | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | updating: #f hide-not-hide-tabs: #f )) ;; 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)) (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! (dboard:commondat-tabdats commondat) tabnum |
︙ | ︙ | |||
1932 1933 1934 1935 1936 1937 1938 | (lambda () (handle-exceptions 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 | | | | | | | 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 | (lambda () (handle-exceptions 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=" 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)))) result-child)) (define (dboard:runs-summary-buttons-updater tabdat) (let loop ((buttons-left (dboard:tabdat-runs-summary-mode-buttons tabdat)) (modes-left (dboard:tabdat-runs-summary-modes tabdat))) |
︙ | ︙ | |||
2721 2722 2723 2724 2725 2726 2727 | (dboard:tabdat-num-tests-set! tabdat (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) | | | 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 | (dboard:tabdat-num-tests-set! tabdat (string->number (or (args:get-arg "-rows") (get-environment-variable "DASHBOARDROWS") "15")))) (define *tim* (iup:timer)) (define *ord* #f) (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) (or please-update-buttons (and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific |
︙ | ︙ |
Modified db.scm from [05478e9bc9] to [411132209a].
︙ | ︙ | |||
208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 | ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;;(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 (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 | > > > > > > | | | | | | | | | | > > > > > > > > > | | | | | | | | | | | | | | | | | | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | ;; returns: db existed-prior-to-opening ;; RA => Returns a db handler; sets the lock if opened in writable mode ;; ;;(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* ((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)))) ))) |
︙ | ︙ | |||
297 298 299 300 301 302 303 | (define (db:open-db dbstruct #!key (areapath #f)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (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")) | | < > | | 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 | (define (db:open-db dbstruct #!key (areapath #f)) ;; TODO: actually use areapath (let ((tmpdb-stack (dbr:dbstruct-dbstack dbstruct))) ;; RA => Returns the first reference in dbstruct (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"))) (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)))) ;;(debug:print-info 13 *default-log-port* "db:open-db>> mtdbpath="mtdbpath" mtdbexists="mtdbexists" and write-access="write-access) |
︙ | ︙ | |||
368 369 370 371 372 373 374 | (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (dbpath (conc dbdir "/" (or name "megatest.db"))) (dbexists (file-exists? dbpath)) (db (db:lock-create-open dbpath (lambda (db) (db:initialize-main-db db) | | > | 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 | (define (db:open-megatest-db #!key (path #f)(name #f)) (let* ((dbdir (or path *toppath*)) (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) ))) (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))) ;; sync run to disk if touched |
︙ | ︙ | |||
1198 1199 1200 1201 1202 1203 1204 | (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, 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)) | | | | | | | | | | | | 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 | (sqlite3:execute db "CREATE TABLE IF NOT EXISTS extradat (id INTEGER PRIMARY KEY, run_id INTEGER, key TEXT, val TEXT);") (sqlite3:execute db "CREATE TABLE IF NOT EXISTS metadat (id INTEGER PRIMARY KEY, var TEXT, val TEXT, 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 (id INTEGER PRIMARY KEY, run_id INTEGER DEFAULT -1, testname TEXT DEFAULT 'noname', host TEXT DEFAULT 'n/a', cpuload REAL DEFAULT -1, diskfree INTEGER DEFAULT -1, uname TEXT DEFAULT 'n/a', |
︙ | ︙ | |||
1232 1233 1234 1235 1236 1237 1238 | comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), 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));") | | | | | | | | | | | | | 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 | comment TEXT DEFAULT '', event_time TIMESTAMP DEFAULT (strftime('%s','now')), 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 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 (id INTEGER PRIMARY KEY, test_id INTEGER, stepname TEXT, state TEXT DEFAULT 'NOT_STARTED', status TEXT DEFAULT 'n/a', 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 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, test_id INTEGER, category TEXT DEFAULT '', variable TEXT, value REAL, expected REAL, tol REAL, units TEXT, 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 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 ( 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 ( 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)) ;;====================================================================== ;; A R C H I V E S ;;====================================================================== ;; dneeded is minimum space needed, scan for existing archives that ;; are on disks with adequate space and already have this test/itempath |
︙ | ︙ | |||
2236 2237 2238 2239 2240 2241 2242 | ;; this is inconsistent with get-runs but it makes some sense. ;; (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)) | | | 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 | ;; this is inconsistent with get-runs but it makes some sense. ;; (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" "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 dbstruct #f #f (lambda (db) |
︙ | ︙ | |||
3305 3306 3307 3308 3309 3310 3311 | dbstruct #f #f (lambda (db) (let ((tr-res (sqlite3:with-transaction db (lambda () ;; NB// Pass the db so it is part fo the transaction | | > > > | > > > > > | | | | > > | 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 | dbstruct #f #f (lambda (db) (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) ;; 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))) (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* >)) (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)) tr-res))))) |
︙ | ︙ |
Added gentargets.sh version [430721a6b7].
> > > > > > | 1 2 3 4 5 6 | #!/bin/bash echo '[v1.63/tip/dev]' echo 'x 1' echo '[v1.64/tip/dev]' echo 'x 1' |
Modified launch.scm from [057f425cdb] to [f0c5aee3f3].
︙ | ︙ | |||
397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (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) (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 (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) | > > | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | (exit))) (if (hash-table-ref/default misc-flags 'keep-going #f) (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 (test-name (assoc/default 'test-name cmdinfo)) (runscript (assoc/default 'runscript cmdinfo)) |
︙ | ︙ | |||
589 590 591 592 593 594 595 | (val (cadr varval))) (if (and (string? var)(string? val)) (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))) | > | | > | > > > > > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 | (val (cadr varval))) (if (and (string? var)(string? val)) (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) (let ((varpairs (string-split set-vars ","))) (debug:print 4 *default-log-port* "varpairs: " varpairs) (map (lambda (varpair) (let ((varval (string-split varpair "="))) (if (eq? (length varval) 2) (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 (setenv var val) (begin (debug:print-error 0 *default-log-port* "required variable " var " does not have a valid value. Exiting") (exit))))) (list (list "MT_TEST_RUN_DIR" work-area) (list "MT_TEST_NAME" test-name) (list "MT_ITEM_INFO" (conc itemdat)) (list "MT_ITEMPATH" item-path) (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) ;; (thread-sleep! 0.3) ;; NFS slowness has caused grief here |
︙ | ︙ | |||
760 761 762 763 764 765 766 | (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (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) | > | | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 | (file-exists? fulldir)) (let ((tmpfile (conc fulldir "/.megatest.cfg." (current-seconds))) (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) (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."))))) ;; gather available information, if legit read configs in this order: ;; |
︙ | ︙ | |||
793 794 795 796 797 798 799 | (debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) (let ((res (launch:setup-body force: force areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) | | | > > > | > > > | | 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 | (debug:print 0 *default-log-port* "NOTE: skipping launch:setup-body call since we have fulldata") (mutex-unlock! *launch-setup-mutex*) *toppath*) (let ((res (launch:setup-body force: force areapath: areapath))) (mutex-unlock! *launch-setup-mutex*) res))) (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)) (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) (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))) ;; (print "runname: " runname " target: " target " mtcachef: " mtcachef " rccachef: " rccachef) (set! *toppath* toppath) ;; This is needed when we are running as a test using CMDINFO as a datasource |
︙ | ︙ |
Modified megatest-version.scm from [d461ac75ec] to [f28f04440f].
1 2 3 4 5 | ;; 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)) | | | 1 2 3 4 5 6 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.6403) |
Modified megatest.config from [303e213485] to [c34072fd64].
1 2 3 4 5 6 7 | [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 | > > > > > | > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 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 [contours] # mode-patt/tag-expr quick selector=QUICKPATT/quick full areas=fullrun,ext-tests; selector=MAXPATT/ all areas=fullrun,ext-tests snazy areas=%; selector=QUICKPATT/ |
Modified megatest.scm from [25aeedf27e] to [d6dfc96888].
︙ | ︙ | |||
280 281 282 283 284 285 286 287 288 289 290 | "-archive" "-since" "-fields" "-recover-test" ;; run-id,test-id - used internally to recover a test stuck in RUNNING state "-sort" "-target-db" "-source-db" "-src-target" "-src-runname" "-diff-email" | > | < | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 | "-archive" "-since" "-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" "-pgsync" "-diff-html" ) (list "-h" "-help" "--help" "-manual" "-version" "-force" |
︙ | ︙ | |||
309 310 311 312 313 314 315 316 317 318 319 320 321 322 | "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" "-no-cache" "-cache-db" "-use-db-cache" ;; misc "-repl" "-lock" "-unlock" "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) | > | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | "-preclean" "-rerun-clean" "-rerun-all" "-clean-cache" "-no-cache" "-cache-db" "-use-db-cache" "-prepend-contour" ;; misc "-repl" "-lock" "-unlock" "-list-servers" "-kill-servers" "-run-wait" ;; wait on a run to complete (i.e. no RUNNING) |
︙ | ︙ | |||
855 856 857 858 859 860 861 | key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin | > | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 | key-vals)) ;; (read-config (conc *toppath* "/runconfigs.config") #f #t sections: sections)))) (runconfig:read (conc *toppath* "/runconfigs.config") target #f)))) (if (and rundir ;; have all needed variabless (directory-exists? rundir) (file-write-access? rundir)) (begin (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)))) (if (args:get-arg "-show-runconfig") (let ((tl (launch:setup))) |
︙ | ︙ |
Modified mtut.scm from [12d335b5eb] to [61b7ccaff4].
︙ | ︙ | |||
26 27 28 29 30 31 32 | (include "megatest-fossil-hash.scm") (require-library stml) (define *target-mappers* (make-hash-table)) ;; '()) (define *runname-mappers* (make-hash-table)) ;; '()) | < < < < | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | (include "megatest-fossil-hash.scm") (require-library stml) (define *target-mappers* (make-hash-table)) ;; '()) (define *runname-mappers* (make-hash-table)) ;; '()) ;; 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? ;; iv. Use compiled version in preference to .scm version. Thus there is a manual "blessing" ;; required to use .mtutil.scm. |
︙ | ︙ | |||
391 392 393 394 395 396 397 | ;; (define (command-line->pkt action args-alist sched-in) (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 | > > | | 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 | ;; (define (command-line->pkt action args-alist sched-in) (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 (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) (map (lambda (x) (let* ((param (car x)) |
︙ | ︙ | |||
881 882 883 884 885 886 887 888 889 890 891 892 893 894 | pkts)))))) (define (get-pkts-dir mtconf) (let ((pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f))) pktsdir)) (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)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) | > > > > | 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 | pkts)))))) (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)) (pktsdirs (configf:lookup mtconf "setup" "pktsdirs")) (pktsdir (if pktsdirs (car (string-split pktsdirs " ")) #f)) |
︙ | ︙ | |||
935 936 937 938 939 940 941 | ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (if (get-environment-variable "HTTP_HOST") (begin (stml:main #f) (exit))) | < | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 | ;; If HTTP_HOST is defined then we must be in the cgi environment ;; so run stml and exit ;; (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 ;; (import csi) (import readline) |
︙ | ︙ |
Modified newdashboard.scm from [f36e3a40a7] to [7ae318679b].
︙ | ︙ | |||
27 28 29 30 31 32 33 | (use canvas-draw) (import canvas-draw-iup) (use sql-de-lite srfi-1 posix regex regex-case srfi-69 typed-records sparse-vectors ;; defstruct (prefix dbi dbi:)) (declare (uses common)) | | | | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | (use canvas-draw) (import canvas-draw-iup) (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 launch)) ;; (declare (uses gutils)) ;; (declare (uses db)) ;; (declare (uses server)) ;; (declare (uses synchash)) (declare (uses dcommon)) ;; (declare (uses tree)) ;; ;; (include "common_records.scm") ;; (include "db_records.scm") ;; (include "key_records.scm") (define help (conc |
︙ | ︙ | |||
120 121 122 123 124 125 126 127 128 129 130 131 | (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (update-search x val) (hash-table-set! *searchpatts* x val)) ;; mtest is actually the megatest.config file ;; (define (mtest toppath window-id) (let* ((curr-row-num 0) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 | (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 (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 #:numlin-visible 3)) (validvals-matrix (iup:matrix |
︙ | ︙ | |||
168 169 170 171 172 173 174 | ;; fill in existing info (for-each (lambda (mat fname) (set! curr-row-num 1) (for-each (lambda (var) (iup:attribute-set! mat (conc curr-row-num ":0") var) | | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | ;; fill in existing info (for-each (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)) (set! curr-row-num (+ curr-row-num 1))) '()));; (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) (iup:attribute-set! mat "0:1" "Value") (iup:attribute-set! mat "0:0" "Var") |
︙ | ︙ | |||
339 340 341 342 343 344 345 | #:numlin 50 #:numcol-visible 8 #: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 | | | 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 | #:numlin 50 #:numcol-visible 8 #: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) ;; (for-each (lambda (mat) ;; (iup:attribute-set! mat "0:1" "Value") ;; (iup:attribute-set! mat "0:0" "Var") (iup:attribute-set! mat "HEIGHT0" 0) (iup:attribute-set! mat "ALIGNMENT1" "ALEFT") |
︙ | ︙ | |||
440 441 442 443 444 445 446 | (iup:split (let* ((tb (iup:treebox #: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)))) | | | | | | | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 | (iup:split (let* ((tb (iup:treebox #: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)) (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) 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 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 '())) (target (if (null? targ/runname) "" (string-intersperse (reverse (cdr (reverse targ/runname))) "/"))) (runname (if (null? targ/runname) "" (car (cdr targ/runname)))) |
︙ | ︙ | |||
556 557 558 559 560 561 562 | #:numlin-visible 7 #:click-cb (lambda (obj lin col status) (print "obj: " obj " lin: " lin " col: " col " status: " status))))) (iup:attribute-set! runs-matrix "RESIZEMATRIX" "YES") (iup:attribute-set! runs-matrix "WIDTH0" "100") | | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 | #:numlin-visible 7 #:click-cb (lambda (obj lin col status) (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) (iup:hbox (iup:frame #:title "Runs browser" (iup:vbox runs-matrix))))) ;; Browse and control a single run |
︙ | ︙ | |||
596 597 598 599 600 601 602 | (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) | | | | | | | | 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 | (iup:attribute-set! tabtop "TABTITLE4" "runconfigs.config") tabtop))) (define *current-window-id* 0) (define (newdashboard dbstruct) (let* ((data (make-hash-table)) (keys '()) ;; (db:get-keys dbstruct)) (runname "%") (testpatt "%") (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 (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" (lambda (x) ;; Want to dedicate no more than 50% of the time to this so skip if ;; 2x delta time has not passed since last query (if (< nextmintime (current-milliseconds)) (let* ((starttime (current-milliseconds)) (changes (dcommon:run-update keys data runname keypatts testpatt states statuses 'full my-window-id)) (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 #f) ;; *dbstruct-local*) (iup:main-loop) |
Modified rmt.scm from [49b292f0a5] to [2cee428d81].
︙ | ︙ | |||
671 672 673 674 675 676 677 678 679 680 681 682 683 684 | (define (rmt:get-main-run-stats run-id) (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: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 ;;====================================================================== | > > > | 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 | (define (rmt:get-main-run-stats run-id) (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 ;;====================================================================== |
︙ | ︙ |
Modified runconfigs.config from [3ca33a1f93] to [ae45c36eb8].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 | # To get emacs font highlighing in the various megatest configs do this: # # Install emacs-goodies-el: # sudo apt install emacs-goodies-el # Add to your ~/.emacs file: # (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) # # 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 # tip will be replaced with hashkey? | > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | # To get emacs font highlighing in the various megatest configs do this: # # Install emacs-goodies-el: # sudo apt install emacs-goodies-el # Add to your ~/.emacs file: # (add-to-list 'auto-mode-alist '("config\\'" . conf-space-mode)) # # 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] # file: files changes since last run trigger new run # script: script is called with unix seconds as last parameter (other parameters are preserved) # # contour:sensetype:action params data quick:file:run runtrans=auto; glob=/home/matt/data/megatest/*.scm snazy:file:run runtrans=corporate-ww; glob=/home/matt/data/megatest/*.scm short:file:run runtrans=short; glob=/home/matt/data/megatest/*.scm |
︙ | ︙ |
Modified runs.scm from [5aecd0eb79] to [fe26303692].
︙ | ︙ | |||
49 50 51 52 53 54 55 56 57 58 59 60 61 62 | hed tal reg reruns test-record test-name item-path jobgroup 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)) (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))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) | > | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | hed tal reg reruns test-record test-name item-path jobgroup 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))) (vals (hash-table-ref/default *env-vars-by-run-id* run-id #f)) (link-tree (common:get-linktree))) ;; (configf:lookup *configdat* "setup" "linktree"))) |
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (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))) (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 | > > > > > | > | > > > | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 | (hash-table-set! *env-vars-by-run-id* run-id ht) (set! vals ht) (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)) (handle-exceptions exn (let ((call-chain (get-call-chain)) (msg ((condition-property-accessor 'exn 'message) exn))) (if (< count 5) (begin ;; this call is colliding, do some crude stuff to fix it. (debug:print 0 *default-log-port* "ERROR: *configdat* was inaccessible! This should never happen. Retry #" count) (launch:setup force-reread: #t) (fatal-loop (+ count 1))) (begin (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)))) (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") (if (and itempath (not (equal? itempath ""))) |
︙ | ︙ |
Modified tasks.scm from [e18dae9779] to [3d363ae696].
︙ | ︙ | |||
612 613 614 615 616 617 618 | ;; gets mtpg-run-id and syncs the record if different ;; (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 | < < < | < > > > > > > > > > > | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 | ;; gets mtpg-run-id and syncs the record if different ;; (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* ((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)) (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) ;; ensure key fields are up to date (pgdb:refresh-run-info |
︙ | ︙ |
Modified tests.scm from [5b19c3cd2c] to [92c19920cd].
︙ | ︙ | |||
1199 1200 1201 1202 1203 1204 1205 | (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (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) | > | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 | (if (and tcfg cache-file) (hash-table-set! tcfg "have fulldata" #t)) ;; mark this as fully read data (if tcfg (hash-table-set! *testconfigs* test-full-name tcfg)) (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) (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) (if (eq? (hash-table-size test-records) 0) '() |
︙ | ︙ |
Modified utils/nbfake from [df0eb253b8] to [bfff85f08b].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | #!/bin/bash ############################################################################### # # 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 # ############################################################################### if [[ -z "$@" ]]; then cat <<__EOF nbfake usage: nbfake <command to run> 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 __EOF exit fi #============================================================================== # Setup | > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #!/bin/bash ############################################################################### # # 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 nbfake usage: nbfake <command to run> 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 #============================================================================== # Setup |
︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 | fi # Set default nbfake log if [[ -z "$MY_NBFAKE_LOG" ]]; then MY_NBFAKE_LOG=NBFAKE-$(date +%GWW%V.%u_%T) fi #============================================================================== # Run and log #============================================================================== cat <<__EOF >&2 #====================================================================== # NBFAKE logging command to: $MY_NBFAKE_LOG | > > > > > > > | | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | fi # 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 $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 $WASHCMD $* >> $MY_NBFAKE_LOG 2>&1 &\"" fi |