;;======================================================================
;; Copyright 2017, Matthew Welland.
;;
;; This file is part of Megatest.
;;
;; Megatest is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; Megatest is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with Megatest. If not, see <http://www.gnu.org/licenses/>.
;;======================================================================
;;======================================================================
;; Cpumod:
;;
;; Put things here don't fit anywhere else
;;======================================================================
(declare (unit testsmod))
(declare (uses debugprint))
(declare (uses mtargs))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses megatestmod))
(declare (uses rmtmod))
(declare (uses stml2))
(declare (uses mtmod))
(declare (uses servermod))
(declare (uses fsmod))
(use srfi-69)
(module testsmod
*
(import scheme)
(cond-expand
(chicken-4
(import chicken
ports
(prefix base64 base64:)
(prefix sqlite3 sqlite3:)
data-structures
extras
files
matchable
md5
message-digest
pathname-expand
posix
posix-extras
regex
regex-case
sparse-vectors
srfi-1
srfi-13
srfi-18
srfi-69
typed-records
z3
debugprint
(prefix mtargs args:)
)
(use srfi-69))
(chicken-5
(import (prefix sqlite3 sqlite3:)
;; data-structures
;; extras
;; files
;; posix
;; posix-extras
chicken.base
chicken.condition
chicken.file
chicken.file.posix
chicken.io
chicken.pathname
chicken.port
chicken.process
chicken.process-context
chicken.process-context.posix
chicken.sort
chicken.string
chicken.time
chicken.time.posix
matchable
md5
message-digest
pathname-expand
regex
regex-case
srfi-1
srfi-18
srfi-69
typed-records
system-information
debugprint
)))
(import directory-utils
debugprint
commonmod
configfmod
dbmod
dbfile
megatestmod
rmtmod
stml2
mtmod
servermod
fsmod
)
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "js-path.scm")
(define (init-java-script-lib)
(set! *java-script-lib* (conc (common:get-install-area) "/share/js/jquery-3.1.0.slim.min.js"))
)
(define (tests:summarize-items run-id test-id test-name force)
;; if not force then only update the record if one of these is true:
;; 1. logf is "log/final.log
;; 2. logf is same as outputfilename
(let* ((outputfilename (conc "megatest-rollup-" test-name ".html"))
(orig-dir (current-directory))
(logf-info (rmt:test-get-logfile-info run-id test-name))
(logf (if logf-info (cadr logf-info) #f))
(path (if logf-info (car logf-info) #f)))
;; This query finds the path and changes the directory to it for the test
(if (and (string? path)
(directory? path)) ;; can get #f here under some wierd conditions. why, unknown ...
(begin
(debug:print 4 *default-log-port* "Found path: " path)
(change-directory path))
;; (set! outputfilename (conc path "/" outputfilename)))
(debug:print-error 0 *default-log-port* "summarize-items for run-id=" run-id ", test-name=" test-name ", no such path: " path))
(debug:print 4 *default-log-port* "summarize-items with logf " logf ", outputfilename " outputfilename " and force " force)
(if (or (equal? logf "logs/final.log")
(equal? logf outputfilename)
force)
(let ((my-start-time (current-seconds))
(lockf (conc outputfilename ".lock")))
(let loop ((have-lock (common:simple-file-lock lockf)))
(if have-lock
(let ((script (configf:lookup *configdat* "testrollup" test-name)))
(debug:print 0 *default-log-port* "Obtained lock for " outputfilename)
(rmt:set-state-status-and-roll-up-items run-id test-name "" #f #f #f)
(if script
(system (conc script " > " outputfilename " & "))
(tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename))
(common:simple-file-release-lock lockf)
(change-directory orig-dir)
;; NB// tests:test-set-toplog! is remote internal...
(tests:test-set-toplog! run-id test-name outputfilename))
;; didn't get the lock, check to see if current update started later than this
;; update, if so we can exit without doing any work
(if (> my-start-time (handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "failed to get mod time on " lockf ", exn=" exn)
0)
(file-modification-time lockf)))
;; we started since current re-gen in flight, delay a little and try again
(begin
(debug:print-info 1 *default-log-port* "Waiting to update " outputfilename ", another test currently updating it")
(thread-sleep! (+ 5 (random 5))) ;; delay between 5 and 10 seconds
(loop (common:simple-file-lock lockf))))))))))
(define (tests:generate-html-summary-for-iterated-test run-id test-id test-name outputfilename)
(let ((counts (make-hash-table))
(statecounts (make-hash-table))
(outtxt "")
(tot 0)
(testdat (rmt:test-get-records-for-index-file run-id test-name)))
(with-output-to-file outputfilename
(lambda ()
(set! outtxt (conc outtxt "<html><title>Summary: " test-name
"</title><body><h2>Summary for " test-name "</h2>"))
(for-each
(lambda (testrecord)
(let ((id (vector-ref testrecord 0))
(itempath (vector-ref testrecord 1))
(state (vector-ref testrecord 2))
(status (vector-ref testrecord 3))
(run_duration (vector-ref testrecord 4))
(logf (vector-ref testrecord 5))
(comment (vector-ref testrecord 6)))
(hash-table-set! counts status (+ 1 (hash-table-ref/default counts status 0)))
(hash-table-set! statecounts state (+ 1 (hash-table-ref/default statecounts state 0)))
(set! outtxt (conc outtxt "<tr>"
;; "<td><a href=\"" itempath "/" logf "\"> " itempath "</a></td>"
"<td><a href=\"" itempath "/test-summary.html\"> " itempath "</a></td>"
"<td>" state "</td>"
"<td><font color=" (common:get-color-from-status status)
">" status "</font></td>"
"<td>" (if (equal? comment "")
" "
comment) "</td>"
"</tr>"))))
(if (list? testdat)
testdat
(begin
(debug:print 0 *default-log-port* "ERROR: failed to get records with rmt:test-get-records-for-index-file run-id=" run-id "test-name=" test-name)
'())))
(print "<table><tr><td valign=\"top\">")
;; Print out stats for status
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>State stats</h2></td></tr>")
(for-each (lambda (state)
(set! tot (+ tot (hash-table-ref statecounts state)))
(print "<tr><td>" state "</td><td>" (hash-table-ref statecounts state) "</td></tr>"))
(hash-table-keys statecounts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td><td valign=\"top\">")
;; Print out stats for state
(set! tot 0)
(print "<table cellspacing=\"0\" border=\"1\"><tr><td colspan=\"2\"><h2>Status stats</h2></td></tr>")
(for-each (lambda (status)
(set! tot (+ tot (hash-table-ref counts status)))
(print "<tr><td><font color=\"" (common:get-color-from-status status) "\">" status
"</font></td><td>" (hash-table-ref counts status) "</td></tr>"))
(hash-table-keys counts))
(print "<tr><td>Total</td><td>" tot "</td></tr></table>")
(print "</td></td></tr></table>")
(print "<table cellspacing=\"0\" border=\"1\">"
"<tr><td>Item</td><td>State</td><td>Status</td><td>Comment</td>"
outtxt "</table></body></html>")
;; (release-dot-lock outputfilename)
;;(rmt:update-run-stats
;; run-id
;; (hash-table-map
;; state-status-counts
;; (lambda (key val)
;; (append key (list val)))))
))))
(define tests:css-jscript-block
#<<EOF
<style type="text/css">
ul.LinkedList { display: block; }
/* ul.LinkedList ul { display: none; } */
.HandCursorStyle { cursor: pointer; cursor: hand; } /* For IE */
th {background-color: #8c8c8c;}
td.test {background-color: #d9dbdd;}
td.PASS {background-color: #347533;}
td.FAIL {background-color: #cc2812;}
td.SKIP{background-color: #FFD733;}
td.WARN {background-color: #EA8724;}
td.WAIVED {background-color: #838A12;}
td.ABORT{background-color: #EA24B7;}
.PASS .link, .SKIP .link, .WARN .link,.WAIVED .link,.ABORT .link, .FAIL .link{color: #FFFFFF;}
</style>
<script type="text/JavaScript">
function filtersome() {
$("tr").show();
$(".test").filter(
function() {
var names = $('#testname').val().split(',');
var good=1;
for (var i=0, len=names.length; i<len; i++) {
var uname=names[i];
console.log("Trying to check for " + uname);
if($(this).text().indexOf(uname) != -1) {
good= 0;
console.log("Found "+uname);
}
}
return good;
}
).parent().hide();
// $(".sum").show();
}
// Add this to the onload event of the BODY element
function addEvents() {
activateTree(document.getElementById("LinkedList1"));
}
// This function traverses the list and add links
// to nested list items
function activateTree(oList) {
// Collapse the tree
for (var i=0; i < oList.getElementsByTagName("ul").length; i++) {
oList.getElementsByTagName("ul")[i].style.display="none";
}
// Add the click-event handler to the list items
if (oList.addEventListener) {
oList.addEventListener("click", toggleBranch, false);
} else if (oList.attachEvent) { // For IE
oList.attachEvent("onclick", toggleBranch);
}
// Make the nested items look like links
addLinksToBranches(oList);
}
// This is the click-event handler
function toggleBranch(event) {
var oBranch, cSubBranches;
if (event.target) {
oBranch = event.target;
} else if (event.srcElement) { // For IE
oBranch = event.srcElement;
}
cSubBranches = oBranch.getElementsByTagName("ul");
if (cSubBranches.length > 0) {
if (cSubBranches[0].style.display == "block") {
cSubBranches[0].style.display = "none";
} else {
cSubBranches[0].style.display = "block";
}
}
}
// This function makes nested list items look like links
function addLinksToBranches(oList) {
var cBranches = oList.getElementsByTagName("li");
var i, n, cSubBranches;
if (cBranches.length > 0) {
for (i=0, n = cBranches.length; i < n; i++) {
cSubBranches = cBranches[i].getElementsByTagName("ul");
if (cSubBranches.length > 0) {
addLinksToBranches(cSubBranches[0]);
cBranches[i].className = "HandCursorStyle";
cBranches[i].style.color = "blue";
cSubBranches[0].style.color = "black";
cSubBranches[0].style.cursor = "auto";
}
}
}
}
</script>
EOF
)
(define tests:css-jscript-block-dynamic
#<<EOF
<script src= ./jquery3.1.0.js></script>
EOF
)
(define (test:js-block javascript-lib)
(conc "<script src=" javascript-lib "></script>" ))
(define tests:css-jscript-block-static (test:js-block *java-script-lib*))
(define (tests:css-jscript-block-cond dynamic)
(if (equal? dynamic #t)
tests:css-jscript-block-dynamic
tests:css-jscript-block-static))
(define (tests:run-record->test-path run numkeys)
(append (take (vector->list run) numkeys)
(list (vector-ref run (+ 1 numkeys)))))
(define (tests:get-rest-data runs header numkeys)
(let ((resh (make-hash-table)))
(for-each
(lambda (run)
(let* ((run-id (db:get-value-by-header run header "id"))
(run-dir (tests:run-record->test-path run numkeys))
(test-data (rmt:get-tests-for-run
run-id
"%" ;; testnamepatt
'() ;; states
'() ;; statuses
#f ;; offset
#f ;; num-to-get
#f ;; hide/not-hide
#f ;; sort-by
#f ;; sort-order
#f ;; 'shortlist ;; qrytype
0 ;; last update
#f)))
(map (lambda (test)
(let* ((test-name (vector-ref test 2))
(test-html-path (conc (vector-ref test 10) "/" (vector-ref test 13)))
(test-item (conc test-name ":" (vector-ref test 11)))
(test-status (vector-ref test 4)))
(if (not (hash-table-ref/default resh test-name #f))
(hash-table-set! resh test-name (make-hash-table)))
(if (not (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f))
(hash-table-set! (hash-table-ref/default resh test-name #f) test-item (make-hash-table)))
(hash-table-set! (hash-table-ref/default (hash-table-ref/default resh test-name #f) test-item #f) run-id (list test-status test-html-path))))
test-data)))
runs)
resh))
;; tests:genrate dashboard body
;;
(define (tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links flag run-patt target-patt)
(let* ((start (* page pg-size))
;(runsdat (rmt:get-runs "%" pg-size start (map (lambda (x)(list x "%")) keys)))
(runsdat (rmt:get-runs-by-patt keys run-patt target-patt start pg-size #f 0 sort-order: "desc"))
; db:get-runs-by-patt keys runnamepatt targpatt offset limit fields last-update
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(ctr 0)
(test-runs-hash (tests:get-rest-data runs header numkeys))
(test-list (hash-table-keys test-runs-hash)))
(s:html tests:css-jscript-block (tests:css-jscript-block-cond flag)
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(get-prev-links page linktree)
(get-next-links page linktree total-runs)
(s:h1 "Summary for " area-name)
(s:h3 "Filter" )
(s:input 'type "text" 'name "testname" 'id "testname" 'length "30" 'onkeyup "filtersome()")
;; top list
(s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
(map (lambda (key)
(let* ((res (s:tr 'class "something"
(s:th key )
(map (lambda (run)
(s:th (vector-ref run ctr)))
runs))))
(set! ctr (+ ctr 1))
res))
keys)
(s:tr
(s:th "Run Name")
(map (lambda (run)
(s:th (db:get-value-by-header run header "runname")))
runs))
(map (lambda (test-name)
(let* ((item-hash (hash-table-ref/default test-runs-hash test-name #f))
(item-keys (sort (hash-table-keys item-hash) string<=?)))
(map (lambda (item-name)
(let* ((res (s:tr 'class item-name
(s:td item-name 'class "test" )
(map (lambda (run)
(let* ((run-test (hash-table-ref/default item-hash item-name #f))
(run-id (db:get-value-by-header run header "id"))
(result (hash-table-ref/default run-test run-id "n/a"))
;(relative-path (get-relative-path))
(status (if (string? result)
result
(car result)))
(link (if (string? result)
result
(if (equal? flag #t)
(s:a (car result) 'href (conc "./test_log?runid=" run-id "&testname=" item-name ))
(s:a (car result) 'href (string-substitute (conc linktree "/") "" (cadr result) "-"))))))
(s:td link 'class status)))
runs))))
res))
item-keys)))
test-list))))))
;; (tests:create-html-tree "test-index.html")
;;
(define (tests:create-html-tree outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '())
(linktree (common:get-linktree))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(run-patt (or (args:get-arg "-run-patt")
(args:get-arg "-runname")
"%"))
(target (or (args:get-arg "-target-patt")
(args:get-arg "-target")
"%"))
(targlist (string-split target "/"))
(numtarg (length targlist))
(targtweaked (if (> numkeys numtarg)
(append targlist (make-list (- numkeys numtarg) "%"))
targlist))
(target-patt (string-join targtweaked "/"))
;(total-runs (rmt:get-num-runs "%")) ;;this needs to be changed to filter by target
(total-runs (rmt:get-runs-cnt-by-patt run-patt target-patt keys ))
(pg-size 10))
(if (common:simple-file-lock lockfile)
(begin
;(print total-runs)
(let loop ((page 0))
(let* ((oup (open-output-file (or outf (conc linktree "/page" page ".html"))))
(get-prev-links (lambda (page linktree )
(let* ((link (if (not (eq? page 0))
(s:a "<<prev" 'href (conc "page" (- page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link)))
(get-next-links (lambda (page linktree total-runs)
(let* ((link (if (> total-runs (+ 10 (* page pg-size)))
(s:a "next>>" 'href (conc "page" (+ page 1) ".html"))
(s:a "" 'href (conc "page" page ".html")))))
link))) )
(print "total runs: " total-runs)
(s:output-new
oup
(tests:dashboard-body page pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #f run-patt target-patt)) ;; update this function
(close-output-port oup)
; (set! page (+ 1 page))
(if (> total-runs (* (+ 1 page) pg-size))
(loop (+ 1 page)))))
(common:simple-file-release-lock lockfile))
(begin
(debug:print 0 *default-log-port* "Failed to get lock on file outf, lockfile: " lockfile) #f))))
(define (tests:readlines filename)
(call-with-input-file filename
(lambda (p)
(let loop ((line (read-line p))
(result '()))
(if (eof-object? line)
(reverse result)
(loop (read-line p) (cons line result)))))))
(define (tests:get-test-log run-id test-name item-name)
(let* ((test-data (rmt:get-tests-for-run
(string->number run-id)
test-name ;; testnamepatt
'() ;; states
'() ;; statuses
#f ;; offset
#f ;; num-to-get
#f ;; hide/not-hide
#f ;; sort-by
#f ;; sort-order
#f ;; 'shortlist ;; qrytype
0 ;; last update
#f))
(path "")
(found 0))
(debug:print-info 0 *default-log-port* "found: " found )
(let loop ((hed (car test-data))
(tal (cdr test-data)))
(debug:print-info 0 *default-log-port* "item: " (vector-ref hed 11) (vector-ref hed 10) "/" (vector-ref hed 13))
(if (equal? (vector-ref hed 11) item-name)
(begin
(set! found 1)
(set! path (conc (vector-ref hed 10) "/" (vector-ref hed 13)))))
(if (and (not (null? tal)) (equal? found 0))
(loop (car tal)(cdr tal))))
(if (equal? path "")
"<H2>Data not found</H2>"
(string-join (tests:readlines path) "\n"))))
(define (tests:dynamic-dboard page)
;(define (tests:create-html-tree o)
(let* (
;(page "1")
(linktree (common:get-linktree))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(targtweaked (make-list numkeys "%"))
(target-patt (string-join targtweaked "/"))
(total-runs (rmt:get-num-runs "%"))
(pg-size 10)
(pg (if (equal? page #f)
0
(- (string->number page) 1)))
(get-prev-links (lambda (pg linktree)
(debug:print-info 0 *default-log-port* "val: " (- 1 pg))
(let* ((link (if (not (eq? pg 0))
(s:a "<<prev " 'href (conc "dashboard?page=" pg ))
(s:a "" 'href (conc "dashboard?page=" pg)))))
link)))
(get-next-links (lambda (pg linktree total-runs)
(debug:print-info 0 *default-log-port* "val: " pg)
(debug:print-info 0 *default-log-port* "val: " total-runs " size" pg-size)
(let* ((link (if (> total-runs (+ 10 (* pg pg-size)))
(s:a "next>> " 'href (conc "dashboard?page=" (+ pg 2) ))
(s:a "" 'href (conc "dashboard?page=" pg )))))
link)))
(html-body (tests:dashboard-body pg pg-size keys numkeys total-runs linktree area-name get-prev-links get-next-links #t "%" target-patt))) ;; update tis function
html-body))
(define (tests:create-html-summary outf)
(let* ((lockfile (conc outf ".lock"))
(linktree (common:get-linktree))
(keys (rmt:get-keys))
(area-name (common:get-testsuite-name))
(run-patt (or (args:get-arg "-run-patt")
(args:get-arg "-runname")
"%"))
(target (or (args:get-arg "-target-patt")
(args:get-arg "-target")
"%"))
(targlist (string-split target "/"))
(numkeys (length keys))
(numtarg (length targlist))
(targtweaked (if (> numkeys numtarg)
(append targlist (make-list (- numkeys numtarg) "%"))
targlist))
(target-patt (string-join targtweaked "/")))
(if (common:simple-file-lock lockfile)
(begin
(let* (;(runsdat1 (rmt:get-runs run-patt #f #f (map (lambda (x)(list x "%")) keys)))
(runsdat (rmt:get-runs-by-patt keys run-patt target-patt #f #f #f 0))
(runs (vector-ref runsdat 1))
(header (vector-ref runsdat 0))
(oup (open-output-file (or outf (conc linktree "/targets.html"))))
(target-hash (test:create-target-hash runs header (length keys))))
(test:create-target-html target-hash oup area-name linktree)
(test:create-run-html runs area-name linktree (length keys) header))
(common:simple-file-release-lock lockfile))
#f)))
(define (test:get-test-hash test-data)
(let ((resh (make-hash-table)))
(map (lambda (test)
(let* ((test-name (vector-ref test 2))
(test-html-path (if (file-exists? (conc (vector-ref test 10) "/test-summary.html"))
(conc (vector-ref test 10) "/test-summary.html" )
(conc (vector-ref test 10) "/" (vector-ref test 13))))
(test-item (vector-ref test 11))
(test-status (vector-ref test 4)))
(if (not (hash-table-ref/default resh test-item #f))
(hash-table-set! resh test-item (make-hash-table)))
(hash-table-set! (hash-table-ref/default resh test-item #f) test-name (list test-status test-html-path))))
test-data)
resh))
(define (test:get-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 (test:create-run-html runs area-name linktree numkeys header)
(map (lambda (run)
(let* ((target (string-join (take (vector->list run) numkeys) "/"))
(run-name (db:get-value-by-header run header "runname"))
(run-time (seconds->work-week/day-time (db:get-value-by-header run header "event_time")))
(oup (if (file-exists? (conc linktree "/" target "/" run-name))
(open-output-file (conc linktree "/" target "/" run-name "/run.html"))
#f))
(run-id (db:get-value-by-header run header "id"))
(test-data (rmt:get-tests-for-run
run-id
"%" ;; testnamepatt
'() ;; states
'() ;; statuses
#f ;; offset
#f ;; num-to-get
#f ;; hide/not-hide
#f ;; sort-by
#f ;; sort-order
#f ;; 'shortlist ;; qrytype
0 ;; last update
#f))
(item-test-hash (test:get-test-hash test-data))
(items (hash-table-keys item-test-hash))
(test-names (test:get-data->b-keys item-test-hash items)))
(if oup
(begin
(s:output-new
oup
(s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)
(s:title "Runs View " run-name)
(s:body
(s:h1 "Runs View " )
(s:h3 "Target" target)
(s:p
(s:b "Run name" ) run-name)
(s:p
(s:b "Run Date" ) run-time)
(s:table 'border 1 'cellspacing 0
(s:tr
(s:th "Items")
(map (lambda (test)
(s:th test))
test-names))
(map (lambda (item)
(let* ((test-hash (hash-table-ref/default item-test-hash item #f)))
(if test-hash
(begin
(s:tr
(s:td 'class "test" item)
(map (lambda (test)
(let* ((test-details (hash-table-ref/default test-hash test #f))
(status (if test-details
(car test-details)))
(link (if test-details
(string-substitute (conc linktree "/" target "/" run-name "/") "" (cadr test-details) "-"))))
(if test-details
(s:td 'class status
(s:a 'class "link" 'href link status ))
(s:td ""))))
test-names))))))
(sort items string<=?))))))
(close-output-port oup))
(debug:print-info 0 "Skip: Dirctory structure " linktree "/" target "/" run-name " does not exist. Megatest will not create run.html"))))
runs))
(define (test:create-target-hash runs header numkeys)
(let ((resh (make-hash-table)))
(for-each
(lambda (run)
(let* ((run-name (db:get-value-by-header run header "runname"))
(target (string-join (take (vector->list run) numkeys) "/"))
(run-list (hash-table-ref/default resh target #f)))
(if (not run-list)
(hash-table-set! resh target (list run-name))
(hash-table-set! resh target (cons run-name run-list)))))
runs)
resh))
(define (test:get-max-run-cnt target-hash targets)
(let* ((cnt 0 ))
(map (lambda (target)
(let* ((runs (hash-table-ref/default target-hash target #f))
(run-length (if runs
(length runs)
0)))
(if (< cnt run-length)
(set! cnt run-length))))
targets)
cnt))
(define (test:pad-runs target-hash targets max-row-length)
(map (lambda (target)
(let loop ((run-list (hash-table-ref/default target-hash target #f)))
(if (< (length run-list) max-row-length)
(begin
(hash-table-set! target-hash target (cons "" run-list))
(loop (hash-table-ref/default target-hash target #f) )))))
targets)
target-hash)
(define (test:create-target-html target-hash oup area-name linktree)
(let* ((targets (hash-table-keys target-hash))
(max-row-length (test:get-max-run-cnt target-hash targets))
(pad-runs-hash (test:pad-runs target-hash targets max-row-length)))
(s:output-new
oup
(s:html tests:css-jscript-block (tests:css-jscript-block-cond #f)
(s:title "Target View " area-name)
(s:body
(s:h1 "Target View " area-name)
(s:table 'id "LinkedList1" 'border "1" 'cellspacing 0
(s:tr 'class "something"
(s:th "Target")
(s:th 'colspan max-row-length "Runs"))
(let* ((tbl (map (lambda (target)
(s:tr
(s:td 'class "test" target)
(let* ((runs (hash-table-ref/default target-hash target #f))
(rest-row (map (lambda (run)
(if (equal? run "")
(s:td run)
(if (file-exists?(conc linktree "/" target "/" run ))
(begin
(s:td
(s:a 'href (conc target "/" run "/run.html") run))))))
(reverse runs))))
rest-row)))
targets)))
tbl)))))
(close-output-port oup)))
(define (tests:create-html-tree-old outf)
(let* ((lockfile (conc outf ".lock"))
(runs-to-process '()))
(if (common:simple-file-lock lockfile)
(let* ((linktree (common:get-linktree))
(oup (open-output-file (or outf (conc linktree "/runs-index.html"))))
(area-name (common:get-testsuite-name))
(keys (rmt:get-keys))
(numkeys (length keys))
(runsdat (rmt:get-runs "%" #f #f (map (lambda (x)(list x "%")) keys)))
(header (vector-ref runsdat 0))
(runs (vector-ref runsdat 1))
(runtreedat (map (lambda (x)
(tests:run-record->test-path x numkeys))
runs))
(runs-htree (common:list->htree runtreedat)))
(set! runs-to-process runs)
(s:output-new
oup
(s:html tests:css-jscript-block
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(s:h1 "Summary for " area-name)
;; top list
(s:ul 'id "LinkedList1" 'class "LinkedList"
(s:li
"Runs"
(common:htree->html runs-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(full-path (conc linktree "/" targ-path))
(run-name (car (reverse p))))
(if (and (common:file-exists? full-path)
(directory? full-path)
(file-write-access? full-path))
(s:a run-name 'href (conc targ-path "/run-summary.html"))
(begin
(debug:print 0 *default-log-port* "INFO: Can't create " targ-path "/run-summary.html")
(conc run-name " (Not able to create summary at " targ-path ")")))))))))))
(close-output-port oup)
(common:simple-file-release-lock lockfile)
(for-each
(lambda (run)
(let* ((test-subpath (tests:run-record->test-path run numkeys))
(run-id (db:get-value-by-header run header "id"))
(run-dir (tests:run-record->test-path run numkeys))
(test-dats (rmt:get-tests-for-run
run-id
"%/" ;; testnamepatt
'() ;; states
'() ;; statuses
#f ;; offset
#f ;; num-to-get
#f ;; hide/not-hide
#f ;; sort-by
#f ;; sort-order
#f ;; 'shortlist ;; qrytype
0 ;; last update
#f))
(tests-tree-dat (map (lambda (test-dat)
;; (tests:run-record->test-path x numkeys))
(let* ((test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(full-name (db:test-make-full-name test-name item-path))
(path-parts (string-split full-name)))
path-parts))
test-dats))
(tests-htree (common:list->htree tests-tree-dat))
(html-dir (conc linktree "/" (string-intersperse run-dir "/")))
(html-path (conc html-dir "/run-summary.html"))
(oup (if (and (common:file-exists? html-dir)
(directory? html-dir)
(file-write-access? html-dir))
(open-output-file html-path)
#f)))
;; (print "run-dir: " run-dir ", tests-tree-dat: " tests-tree-dat)
(if oup
(begin
(s:output-new
oup
(s:html tests:css-jscript-block
(s:title "Summary for " area-name)
(s:body 'onload "addEvents();"
(s:h1 "Summary for " (string-intersperse run-dir "/"))
;; top list
(s:ul 'id "LinkedList1" 'class "LinkedList"
(s:li
"Tests"
(common:htree->html tests-htree
'()
(lambda (x p)
(let* ((targ-path (string-intersperse p "/"))
(test-name (car p))
(item-path ;; (if (> (length p) 2) ;; test-name + run-name
(string-intersperse p "/"))
(full-targ (conc html-dir "/" targ-path))
(std-file (conc full-targ "/test-summary.html"))
(alt-file (conc full-targ "/megatest-rollup-" test-name ".html"))
(html-file (if (common:file-exists? alt-file)
alt-file
std-file))
(run-name (car (reverse p))))
(if (and (not (common:file-exists? full-targ))
(directory? full-targ)
(file-write-access? full-targ))
(tests:summarize-test
run-id
(rmt:get-test-id run-id test-name item-path)))
(if (common:file-exists? full-targ)
(s:a run-name 'href html-file)
(begin
(debug:print 0 *default-log-port* "ERROR: can't access " full-targ)
(conc "No summary for " run-name)))))
))))))
(close-output-port oup)))))
runs)
#t)
#f)))
;; CHECK - WAS THIS ADDED OR REMOVED? MANUAL MERGE WITH API STUFF!!!
;;
;; get a pretty table to summarize steps
;;
;; (define (dcommon:process-steps-table steps);; db test-id #!key (work-area #f))
(define (tests:process-steps-table steps);; db test-id #!key (work-area #f))
;; (let ((steps (db:get-steps-for-test db test-id work-area: work-area)))
;; organise the steps for better readability
(let ((res (make-hash-table)))
(for-each
(lambda (step)
(debug:print 6 *default-log-port* "step=" step)
(let ((record (hash-table-ref/default
res
(tdb:step-get-stepname step)
;; 0 1 2 3 4 5 6 7
;; stepname start end status Duration Logfile Comment first-id
(vector (tdb:step-get-stepname step) "" "" "" "" "" "" #f))))
(debug:print 6 *default-log-port* "record(before) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))
(if (not (vector-ref record 7))(vector-set! record 7 (tdb:step-get-id step))) ;; do not clobber the id if previously set
(case (string->symbol (tdb:step-get-state step))
((start)(vector-set! record 1 (tdb:step-get-event_time step))
(vector-set! record 3 (if (equal? (vector-ref record 3) "")
(tdb:step-get-status step)))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step))))
((end)
(vector-set! record 2 (any->number (tdb:step-get-event_time step)))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (let ((startt (any->number (vector-ref record 1)))
(endt (any->number (vector-ref record 2))))
(debug:print 4 *default-log-port* "record[1]=" (vector-ref record 1)
", startt=" startt ", endt=" endt
", get-status: " (tdb:step-get-status step))
(if (and (number? startt)(number? endt))
(seconds->hr-min-sec (- endt startt)) "-1")))
(if (> (string-length (tdb:step-get-logfile step))
0)
(vector-set! record 5 (tdb:step-get-logfile step)))
(if (> (string-length (tdb:step-get-comment step))
0)
(vector-set! record 6 (tdb:step-get-comment step))))
(else
(vector-set! record 2 (tdb:step-get-state step))
(vector-set! record 3 (tdb:step-get-status step))
(vector-set! record 4 (tdb:step-get-event_time step))
(vector-set! record 6 (tdb:step-get-comment step))))
(hash-table-set! res (tdb:step-get-stepname step) record)
(debug:print 6 *default-log-port* "record(after) = " record
"\nid: " (tdb:step-get-id step)
"\nstepname: " (tdb:step-get-stepname step)
"\nstate: " (tdb:step-get-state step)
"\nstatus: " (tdb:step-get-status step)
"\ntime: " (tdb:step-get-event_time step))))
;; (else (vector-set! record 1 (tdb:step-get-event_time step)))
(sort steps (lambda (a b)
(cond
((< (tdb:step-get-event_time a)(tdb:step-get-event_time b)) #t)
((eq? (tdb:step-get-event_time a)(tdb:step-get-event_time b))
(< (tdb:step-get-id a) (tdb:step-get-id b)))
(else #f)))))
res))
;;
;;
(define (tests:get-compressed-steps run-id test-id)
(let* ((steps-data (rmt:get-steps-for-test run-id test-id)) ;; 0 1 2 3 4 5 6 7
(comprsteps (tests:process-steps-table steps-data))) ;; #<stepname start end status Duration Logfile Comment id>
(map (lambda (x)
;; take advantage of the \n on time->string
(vector ;; we are constructing basically the original vector but collapsing start end records
(vector-ref x 0) ;; id 0
(let ((s (vector-ref x 1)))
(if (number? s)(seconds->time-string s) s)) ;; starttime 1
(let ((s (vector-ref x 2)))
(if (number? s)(seconds->time-string s) s)) ;; endtime 2
(vector-ref x 3) ;; status 3
(vector-ref x 4) ;; duration 4
(vector-ref x 5) ;; logfile 5
(vector-ref x 6) ;; comment 6
(vector-ref x 7))) ;; id 7
(sort (hash-table-values comprsteps)
(lambda (a b)
(let ((time-a (vector-ref a 1))
(time-b (vector-ref b 1))
(id-a (vector-ref a 7))
(id-b (vector-ref b 7)))
(if (and (number? time-a)(number? time-b))
(if (< time-a time-b)
#t
(if (eq? time-a time-b)
(< id-a id-b)
;; (string<? (conc (vector-ref a 2))
;; (conc (vector-ref b 2)))
#f))
(string<? (conc time-a)(conc time-b)))))))))
;; Save test state and status in to a file .final-status in the test directory
;;
(define (tests:save-final-status run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(status-file (conc out-dir "/.final-status"))
)
;; first verify we are able to write the output file
(if (not (file-write-access? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write .final-status to " out-dir)
(let* ((outp (open-output-file status-file))
(status (db:test-get-status test-dat))
(state (db:test-get-state test-dat)))
(with-output-to-port outp
(lambda ()
(print state) ;; printf was putting in ", not sure why but that was a hassle in other contexts
(print status)))
(close-output-port outp)))))
;; summarize test in to a file test-summary.html in the test directory
;;
(define (tests:summarize-test run-id test-id)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(out-dir (db:test-get-rundir test-dat))
(out-file (conc out-dir "/test-summary.html")))
;; first verify we are able to write the output file
(if (not (file-write-access? out-dir))
(debug:print 0 *default-log-port* "ERROR: cannot write test-summary.html to " out-dir)
(let* (;; (steps-dat (rmt:get-steps-for-test run-id test-id))
(test-name (db:test-get-testname test-dat))
(item-path (db:test-get-item-path test-dat))
(full-name (db:test-make-full-name test-name item-path))
(oup (open-output-file out-file))
(status (db:test-get-status test-dat))
(color (common:get-color-from-status status))
(logf (db:test-get-final_logf test-dat))
(steps-dat (tests:get-compressed-steps run-id test-id)))
;; (dcommon:get-compressed-steps #f 1 30045)
;; (#("wasting_time" "23:36:13" "23:36:21" "0" "8.0s" "wasting_time.log"))
(s:output-new
oup
(s:html
(s:title "Summary for " full-name)
(s:body
(s:h2 "Summary for " full-name)
(s:table 'cellspacing "0" 'border "1"
(s:tr (s:td "run id") (s:td (db:test-get-run_id test-dat))
(s:td "test id") (s:td (db:test-get-id test-dat)))
(s:tr (s:td "testname") (s:td test-name)
(s:td "itempath") (s:td item-path))
(s:tr (s:td "state") (s:td (db:test-get-state test-dat))
(s:td "status") (s:td (s:a 'href logf (s:font 'color color status))))
(s:tr (s:td "TestDate") (s:td (seconds->work-week/day-time
(db:test-get-event_time test-dat)))
(s:td "Duration") (s:td (seconds->hr-min-sec (db:test-get-run_duration test-dat)))))
(s:h3 "Log files")
(s:table
'cellspacing "0" 'border "1"
(s:tr (s:td "Final log")(s:td (s:a 'href logf logf))))
(s:table
'cellspacing "0" 'border "1"
(s:tr (s:td "Step Name")(s:td "Start")(s:td "End")(s:td "Status")(s:td "Duration")(s:td "Log File"))
(map (lambda (step-dat)
(s:tr (s:td (tdb:steps-table-get-stepname step-dat))
(s:td (tdb:steps-table-get-start step-dat))
(s:td (tdb:steps-table-get-end step-dat))
(s:td (tdb:steps-table-get-status step-dat))
(s:td (tdb:steps-table-get-runtime step-dat))
(s:td (let ((step-log (tdb:steps-table-get-log-file step-dat)))
(s:a 'href step-log step-log)))))
steps-dat))
)))
(close-output-port oup)))))
;; MUST BE CALLED local!
;;
(define (tests:test-get-paths-matching keynames target fnamepatt #!key (res '()))
;; BUG: Move the values derived from args to parameters and push to megatest.scm
(let* ((testpatt (or (args:get-arg "-testpatt")(args:get-arg "-testpatt") "%"))
(statepatt (or (args:get-arg "-state") (args:get-arg ":state") "%"))
(statuspatt (or (args:get-arg "-status") (args:get-arg ":status") "%"))
(runname (or (args:get-arg "-runname") (args:get-arg ":runname") "%"))
(paths-from-db (rmt:test-get-paths-matching-keynames-target-new keynames target res
testpatt
statepatt
statuspatt
runname)))
(if fnamepatt
(apply append
(map (lambda (p)
(if (directory-exists? p)
(let ((glob-query (conc p "/" fnamepatt)))
(handle-exceptions
exn
(begin
(print "built-in glob on " glob-query ", failed, try using the shell. exn=" exn)
(with-input-from-pipe
(conc "echo " glob-query)
read-lines)) ;; we aren't going to try too hard. If glob breaks it is likely because someone tried to do */*/*.log or similar
(glob glob-query)))
'()))
paths-from-db))
paths-from-db)))
;;======================================================================
;; Gather data from test/task specifications
;;======================================================================
;; (define (tests:get-valid-tests testsdir test-patts) ;; #!key (test-names '()))
;; (let ((tests (glob (conc testsdir "/tests/*")))) ;; " (string-translate patt "%" "*")))))
;; (set! tests (filter (lambda (test)(common:file-exists? (conc test "/testconfig"))) tests))
;; (delete-duplicates
;; (filter (lambda (testname)
;; (tests:match test-patts testname #f))
;; (map (lambda (testp)
;; (last (string-split testp "/")))
;; tests)))))
;; 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)
'()
(let* ((mungepriority (lambda (priority)
(if priority
(let ((tmp (any->number priority)))
(if tmp tmp (begin (debug:print-error 0 *default-log-port* "bad priority value " priority ", using 0") 0)))
0)))
(all-tests (hash-table-keys test-records))
(all-waited-on (let loop ((hed (car all-tests))
(tal (cdr all-tests))
(res '()))
(let* ((trec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons trec) '())))
(if (null? tal)
(append res waitons)
(loop (car tal)(cdr tal)(append res waitons))))))
(sort-fn1
(lambda (a b)
(let* ((a-record (hash-table-ref test-records a))
(b-record (hash-table-ref test-records b))
(a-waitons (or (tests:testqueue-get-waitons a-record) '()))
(b-waitons (or (tests:testqueue-get-waitons b-record) '()))
(a-config (tests:testqueue-get-testconfig a-record))
(b-config (tests:testqueue-get-testconfig b-record))
(a-raw-pri (configf:lookup a-config "requirements" "priority"))
(b-raw-pri (configf:lookup b-config "requirements" "priority"))
(a-priority (mungepriority a-raw-pri))
(b-priority (mungepriority b-raw-pri)))
(tests:testqueue-set-priority! a-record a-priority)
(tests:testqueue-set-priority! b-record b-priority)
;; (debug:print 0 *default-log-port* "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
(cond
;; is
((member a b-waitons) ;; is b waiting on a?
;; (debug:print 0 *default-log-port* "case1")
#t)
((member b a-waitons) ;; is a waiting on b?
;; (debug:print 0 *default-log-port* "case2")
#f)
((and (not (null? a-waitons)) ;; both have waitons - do not disturb
(not (null? b-waitons)))
;; (debug:print 0 *default-log-port* "case2.1")
#t)
((and (null? a-waitons) ;; no waitons for a but b has waitons
(not (null? b-waitons)))
;; (debug:print 0 *default-log-port* "case3")
#f)
((and (not (null? a-waitons)) ;; a has waitons but b does not
(null? b-waitons))
;; (debug:print 0 *default-log-port* "case4")
#t)
((not (eq? a-priority b-priority)) ;; use
(> a-priority b-priority))
(else
;; (debug:print 0 *default-log-port* "case5")
(string>? a b))))))
(sort-fn2
(lambda (a b)
(> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
(mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
;; (let ((dot-res (tests:run-dot (tests:tests->dot test-records) "plain")))
;; (debug:print "dot-res=" dot-res))
;; (let ((data (map cdr (filter
;; (lambda (x)(equal? "node" (car x)))
;; (map string-split (tests:easy-dot test-records "plain"))))))
;; (map car (sort data (lambda (a b)
;; (> (string->number (caddr a))(string->number (caddr b)))))))
;; ))
(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table
(define (tests:easy-dot test-records outtype)
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
(format temp-port " size=4,8\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
(waitons (or (tests:testqueue-get-waitons testrec) '())))
(for-each
(lambda (waiton)
(format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n")))
waitons)))
all-testnames)
(format temp-port "}\n")
(close-output-port temp-port)
(with-input-from-pipe
(conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
(lambda ()
(let ((res (read-lines)))
;; (delete-file temp-path)
res))))))
(define (tests:write-dot-file test-records fname sizex sizey)
(if (file-write-access? (pathname-directory fname))
(with-output-to-file fname
(lambda ()
(map print (tests:tests->dot test-records sizex sizey))))))
(define (tests:tests->dot test-records sizex sizey)
(let ((all-testnames (hash-table-keys test-records)))
(if (null? all-testnames)
'()
(let loop ((hed (car all-testnames))
(tal (cdr all-testnames))
(res (list "digraph tests {"
(conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
" ratio=0.95;"
)))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(newres (append res
(if (null? waitons)
(list (conc " \"" hed "\" [shape=box];"))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\" [shape=box];"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
(define (tests:run-dot indat outtype) ;; outtype is plain, fig, dot, etc. http://www.graphviz.org/content/output-formats
(let-values (((inp oup pid)(process "env -i PATH=\"$PATH\" dot" (list "-T" outtype))))
(with-output-to-port oup
(lambda ()
(map print indat)))
(close-output-port oup)
(let ((res (with-input-from-port inp
(lambda ()
(read-lines)))))
(close-input-port inp)
res)))
;; read data from tmp file or create if not exists
;; if exists regen in background
;;
(define (tests:lazy-dot testrecords outtype sizex sizey)
(let ((dfile (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dot"))
(fname (conc "/tmp/." (current-user-name) "-" (server:mk-signature) ".dotdat")))
(tests:write-dot-file testrecords dfile sizex sizey)
(if (common:file-exists? fname)
(let ((res (with-input-from-file fname
(lambda ()
(read-lines)))))
(system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname "&"))
res)
(begin
(system (conc "env -i PATH=\"$PATH\" dot -T " outtype " < " dfile " > " fname))
(with-input-from-file fname
(lambda ()
(read-lines)))))))
;; for each test:
;;
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
(let ((runnables '()))
(for-each
(lambda (testkeyname)
(let* ((test-record (hash-table-ref testrecordshash testkeyname))
(test-name (tests:testqueue-get-testname test-record))
(itemdat (tests:testqueue-get-itemdat test-record))
(item-path (tests:testqueue-get-item_path test-record))
(waitons (tests:testqueue-get-waitons test-record))
(keep-test #t)
(test-id (rmt:get-test-id run-id test-name item-path))
(tdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if tdat
(begin
;; Look at the test state and status
(if (or (and (member (db:test-get-status tdat)
'("PASS" "WARN" "WAIVED" "CHECK" "SKIP"))
(equal? (db:test-get-state tdat) "COMPLETED"))
(member (db:test-get-state tdat)
'("INCOMPLETE" "KILLED")))
(set! keep-test #f))
;; examine waitons for any fails. If it is FAIL or INCOMPLETE then eliminate this test
;; from the runnable list
(if keep-test
(for-each (lambda (waiton)
;; for now we are waiting only on the parent test
(let* ((parent-test-id (rmt:get-test-id run-id waiton ""))
(wtdat (rmt:get-testinfo-state-status run-id test-id))) ;; (cdb:get-test-info-by-id *runremote* test-id)))
(if (or (and (equal? (db:test-get-state wtdat) "COMPLETED")
(member (db:test-get-status wtdat) '("FAIL" "ABORT")))
(member (db:test-get-status wtdat) '("KILLED"))
(member (db:test-get-state wtdat) '("INCOMPETE")))
;; (if (or (member (db:test-get-status wtdat)
;; '("FAIL" "KILLED"))
;; (member (db:test-get-state wtdat)
;; '("INCOMPETE")))
(set! keep-test #f)))) ;; no point in running this one again
waitons))))
(if keep-test (set! runnables (cons testkeyname runnables)))))
testkeynames)
runnables))
;;======================================================================
;; test steps
;;======================================================================
;; teststep-set-status! used to be here
;; NOT NEEDED
#;(define (test-get-kill-request run-id test-id) ;; run-id test-name itemdat)
(let* ((testdat (rmt:get-test-state-status-by-id run-id test-id)))
(and testdat
(equal? (car testdat) "KILLREQ"))))
(define (test:tdb-get-rundat-count tdb)
(if tdb
(let ((res 0))
(sqlite3:for-each-row
(lambda (count)
(set! res count))
tdb
"SELECT count(id) FROM test_rundat;")
res))
0)
(define (tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)
(rmt:general-call 'update-test-rundat run-id test-id (current-seconds) (or cpuload -1)(or diskfree -1) -1 (or minutes -1))
(if (and cpuload diskfree)
(rmt:general-call 'update-cpuload-diskfree run-id cpuload diskfree test-id))
(if minutes
(rmt:general-call 'update-run-duration run-id minutes test-id))
(if (and uname hostname)
(rmt:general-call 'update-uname-host run-id uname hostname test-id)))
;; This one is for running with no db access (i.e. via rmt: internally)
(define (tests:set-full-meta-info db test-id run-id minutes work-area remtries)
;; (define (tests:set-full-meta-info test-id run-id minutes work-area)
;; (let ((remtries 10))
(let* ((cpuload (commonmod:get-cpu-load))
(diskfree (get-df (current-directory)))
(uname (get-uname "-srvpio"))
(hostname (get-host-name)))
(tests:update-central-meta-info run-id test-id cpuload diskfree minutes uname hostname)))
;; (define (tests:set-partial-meta-info test-id run-id minutes work-area)
#;(define (tests:set-partial-meta-info test-id run-id minutes work-area remtries)
(let* ((cpuload (get-cpu-load))
(diskfree (get-df (current-directory)))
(remtries 10))
(handle-exceptions
exn
(if (> remtries 0)
(begin
(print-call-chain (current-error-port))
(debug:print-info 0 *default-log-port* "WARNING: failed to set meta info. Will try " remtries " more times")
(set! remtries (- remtries 1))
(thread-sleep! 10)
(tests:set-full-meta-info db test-id run-id minutes work-area (- remtries 1)))
(let ((err-status ((condition-property-accessor 'sqlite3 'status #f) exn)))
(debug:print-error 0 *default-log-port* "tried for over a minute to update meta info and failed. Giving up")
(debug:print 0 *default-log-port* "EXCEPTION: database probably overloaded or unreadable.")
(debug:print 0 *default-log-port* " message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 5 *default-log-port* "exn=" (condition->list exn))
(debug:print 0 *default-log-port* " status: " ((condition-property-accessor 'sqlite3 'status) exn))
(print-call-chain (current-error-port))))
(tests:update-testdat-meta-info db test-id work-area cpuload diskfree minutes)
)))
;;======================================================================
;; A R C H I V I N G
;;======================================================================
(define (test:archive db test-id)
#f)
(define (test:archive-tests db keynames target)
#f)
)