;;======================================================================
;; Extracting the data to display for runs
;;
;; This needs to be re-entrant such that it does one column per call
;; on the zeroeth call update runs data
;; on each subsequent call update one run (configurable - could do two, three ... or update until tdelta exceeded
;; on last run reset to zeroeth
;;
;; 1. select with run filters; area, target, runname, runstate, runstatus, starttime, duration
;; - put this information into two data structures:
;; a. hash of area/target/runname => runstruct #< ordernun, id, area, target, runname, state,
;; status, starttime, duration, non-deleted testcount>
;; ordernum reflects order as received from sql query
;; b. sparsevec of id => runstruct
;; 2. for each run in runshash ordered by ordernum do:
;; retrieve data since last update for that run
;; if there is a deleted test - retrieve full data
;; if there are non-deleted tests register this run in the columns sparsevec
;; if this is the zeroeth column regenerate the rows sparsevec
;; if this column is in the visible zone update visible cells
;;
;; Other factors:
;; 1. left index handling:
;; - add test/itempaths to left index as discovered, re-order and
;; update row -> test/itempath mapping on each read run
;;======================================================================
;; runs is <vec header runs>
;; get ALL runs info
;; update rdat-targ-run-id
;; update rdat-runs
;;
(define (dashboard:update-runs-data rdat)
(let* ((tb (dboard:rdat-runs-tree rdat))
(targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
(runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
(state-sql-filt (dboard:rdat-run-state-sql-filt rdat))
(status-sql-filt (dboard:rdat-run-status-sql-filt rdat))
;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
(data (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt #f))
(numruns (length data)))
;; store in the runsbynum vector
(dboard:rdat-runsbynum-set! rdat (list->vector data))
;; update runs id => runrec
;; update targ-runid target/runname => run-id
(for-each
(lambda (runrec)
(let* ((run-id (simple-run-id runrec))
(full-targ-runname (conc (simple-run-target runrec) "/"
(simple-run-runname runrec))))
;; (debug:print 0 *default-log-port* "Update run " run-id)
(sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
(hash-table-set! (dboard:rdat-targ-runid rdat) full-targ-runname run-id)
(tree:add-node tb "Runs" (string-split full-targ-runname "/"))
))
data)
numruns))
;;======================================================================
;; The "new" runs browser, this one sets up the view and registers the
;; updater
;;
(define (dashboard:runs-browse commondat tabdat #!key (tab-num 5))
(let* ((rdat (make-dboard:rdat))
(runsmtx (dboard:runs-new-matrix commondat rdat))
(itemsmtx (dboard:runs-new-matrix commondat rdat)))
(dboard:rdat-runs-mtx-set! rdat runsmtx)
(dboard:rdat-items-mtx-set! rdat itemsmtx)
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:new-runs-updater commondat tabdat rdat))
tab-num: tab-num)
(iup:split
#:orientation "VERTICAL"
#:value 100
#:shrink "YES"
(iup:vbox
(dboard:runs-tree-new-view-browser commondat rdat))
(iup:split
#:orientation "VERTICAL"
#:value 100
(iup:vbox runsmtx)
(iup:vbox
(iup:split
#:orientation "VERTICAL"
#:value 500
itemsmtx
(dboard:test-info-matrix commondat rdat)
))))))
(define (dashboard:new-runs-updater commondat tabdat rdat)
(let* ((runnum (dboard:rdat-runnum rdat))
(start-time (current-milliseconds))
(tot-runs #f))
(if (eq? runnum 0)(dashboard:update-runs-data rdat))
(set! tot-runs (vector-length (dboard:rdat-runsbynum rdat)))
(let loop ((rn runnum))
(if (and (< (- (current-milliseconds) start-time) 250)
(< rn tot-runs))
(let* ((newrn (if (>= runnum (vector-length (dboard:rdat-runsbynum rdat)))
0 ;; start over
(+ rn 1)))) ;; (+ runnum 1)))
(dashboard:update-run-data rn rdat)
(dboard:rdat-runnum-set! rdat newrn)
(if (> newrn 0)
(loop newrn)))))
(if (>= (dboard:rdat-runnum rdat) tot-runs)
(dboard:rdat-runnum-set! rdat 0))
;; (dboard:rdat-runnum-set! rdat rn))) ;; not needed as it is set above
;; (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
(dashboard:update-new-runs-view-runs-matrix commondat rdat)
'()))
;; NOTE: runnum is NOT the run-id, it is a pointer into the runsbynum vector
;;
(define (dashboard:update-run-data runnum rdat)
(let* ((curr-time (current-seconds))
(runrec (vector-ref (dboard:rdat-runsbynum rdat) runnum))
(run-id (simple-run-id runrec))
(last-update (sparse-vector-ref (dboard:rdat-last-updates rdat) run-id))
;; filters
(testname-sql-filt (dboard:rdat-testname-sql-filt rdat))
;; (itempath-sql-filt (dboard:rdat-itempath-sql-filt rdat))
(test-state-sql-filt (dboard:rdat-test-state-sql-filt rdat)) ;; not used yet
(test-status-sql-filt (dboard:rdat-test-status-sql-filt rdat)) ;; not used yet
(tests (rmt:get-tests-for-run-state-status run-id
testname-sql-filt
last-update ;; last-update
)))
;; (debug:print 0 *default-log-port* "tests: " tests)
(sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
(sparse-vector-set! (dboard:rdat-run-tests rdat) run-id
(delete-duplicates
(append tests (sparse-vector-ref (dboard:rdat-run-tests rdat) run-id))
(lambda (a b)
(eq? (vector-ref a 0)(vector-ref b 0))))) ;; de-duplicate based on test id
#;(debug:print 0 *default-log-port* "Got " (length tests) " tests for run-id "
run-id " testname-sql-filt " testname-sql-filt " and last-update " last-update
" first test info: " tests) ;; (if (not (null? tests))(car tests) '()))
(length tests)))
;; NB// start at 1.
;;
(define (dashboard:get-row-num mtrx rownames tname)
(or (hash-table-ref/default rownames tname #f)
(let* ((numentries (hash-table-size rownames))
(nextnum (+ numentries 1)))
(hash-table-set! rownames tname nextnum)
(iup:attribute-set! mtrx (conc nextnum ":0") tname)
nextnum)))
(define (dashboard:update-new-runs-view-runs-matrix commondat rdat)
(let* ((run-tests-data (dboard:rdat-run-tests rdat)) ;; from dbmod.scm (define-record simple-run target id runname state status owner event_time)
(run-tests-mtx (dboard:rdat-runs-mtx rdat))
(runs-by-num (dboard:rdat-runsbynum rdat)) ;; this is the sequence num
(num-runs (vector-length runs-by-num))
)
(debug:print 0 *default-log-port* "num-runs: " num-runs)
(let loop ((col-num 1))
(let* ((runrec (vector-ref runs-by-num (- col-num 1)))
(run-id (simple-run-id runrec))
(target (simple-run-target runrec))
(runname (simple-run-runname runrec))
(vert-targ (string-translate (conc target "/" runname) "/" "\n"))
(run-tests (sparse-vector-ref run-tests-data run-id))
(changed #f)) ;; manage redraws on a column by column basis
(debug:print 0 *default-log-port* "run-tests: " run-tests)
(if (null? run-tests) ;; empty run
(if (< col-num num-runs) ;; NOT CORRECT
(loop (+ col-num)))
(begin
(set! changed (dcommon:modifiy-if-different ;; set the col header
run-tests-mtx
(conc "0:" col-num)
vert-targ
changed))
(let testloop ((inum 0)
(tail run-tests))
(let* ((test-dat (car tail))
(tname (db:test-get-testname test-dat))
(state (db:test-get-state test-dat))
(status (db:test-get-status test-dat))
(item-path (db:test-get-item-path test-dat))
(color (gutils:get-color-for-state-status state status))
(is-deleted (equal? state "DELETED"))
(row-num (if is-deleted
#f
(dashboard:get-row-num run-tests-mtx
(dboard:rdat-rownames rdat) tname)))
(cell-name (conc row-num ":" col-num)))
(if (or (not is-deleted)
(equal? item-path ""))
(begin
(set! changed (dcommon:modifiy-if-different
run-tests-mtx
(conc "BGCOLOR" row-num ":" col-num)
(car color)
changed))
(set! changed (dcommon:modifiy-if-different
run-tests-mtx
cell-name
(cadr color)
changed))))
(if (not (null? (cdr tail)))
(testloop (+ inum 1)(cdr tail))
(begin
(iup:attribute-set! run-tests-mtx (conc "C" col-num) "REDRAW")
(if (< col-num num-runs)
(loop (+ col-num 1)))))))))))))
(define (dboard:runs-new-matrix commondat rdat)
(iup:matrix
#:alignment1 "ALEFT"
#:expand "YES" ;; "HORIZONTAL"
#:scrollbar "YES"
#:numcol 100
#:numlin 200
#:numcol-visible 3 ;; (min 8)
#:numlin-visible 10
#:widthdef 20
#:click-cb
(lambda (obj row col status)
(let* ((cell (conc row ":" col)))
#f))
))
;; run info, test info
(define (dboard:test-info-matrix commondat rdat)
(let* ((run-fields
'(("Run Info" . 1)
("Fields" . 2)
("Target" . 3)
("Runname" . 4)
("Run-id" . 5)
("Run-date" . 6)))
(test-fields
'(("Test Info" . 1)
("Testname" . 2)
("Item path" . 3)
("State" . 4)
("Status" . 5)
("Comment" . 6)
("Test-id" . 7)
("Test-date" . 8)))
(test-meta-fields
'(("Test Meta Data" . 1)
("Author" . 2)
("Owner" . 3)
("Reviewed" . 4)
("Tags" . 5)
("Description" . 6)))
(remhost-run-info-fields
'(("Host/run info" . 1)
("Hostname" . 2)
("Disk free" . 3)
("CPU Load" . 4)
("Run duration" . 5)
("Logfile" . 6)
("Process ID" . 7)
("Machine info" . 8)))
(mk-matrix (lambda (cfgdat)
(let ((mtx (iup:matrix
#:alignment1 "ALEFT"
;; #:expand "YES" ;; "HORIZONTAL"
#:scrollbar "YES"
#:numcol 1
#:numlin (length cfgdat)
#:numcol-visible 1 ;; (min 8)
#:numlin-visible (length cfgdat)
#:widthdef 50
#:width0 50
#:click-cb
(lambda (obj row col status)
(let* ((cell (conc row ":" col)))
#f)))))
(for-each (lambda (finfo)
(match finfo
((fieldname . rownum)
(iup:attribute-set! mtx (conc rownum":0") fieldname))
(else (debug:print 0 *default-log-port* "ERROR: bad finfo "finfo))))
cfgdat)
mtx)))
(runmtx (mk-matrix run-fields))
(testmtx (mk-matrix test-fields))
(metamtx (mk-matrix test-meta-fields))
(remhostmtx (mk-matrix remhost-run-info-fields)))
;; (dboard:rdat-runs-mtx-set! rdat runmtx)
;; (dboard:rdat-items-mtx-set! rdat testmtx)
;; (
(iup:vbox
#:expandchildren #t
#:expand #f
runmtx testmtx
metamtx remhostmtx
)))
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
;; THIS IS THE NEW ONE
;;
(define (dboard:runs-tree-new-view-browser commondat rdat)
(let* ((txtbox (iup:textbox
#:action (lambda (val a b)
(debug:catch-and-dump
(lambda ()
;; for the Runs view we put the list
;; of keyvals into tabdat target for
;; the Run Controls we put then update
;; the run-command
(if b (dboard:rdat-targ-sql-filt-set! rdat
(string-split b "/")))
#;(dashboard:update-run-command tabdat))
"command-testname-selector tb action"))
;; #:value (dboard:test-patt->lines ;; This seems like it was wrong, BUG in code where it was copied from?
;; (dboard:tabdat-test-patts-use tabdat))
#:expand "HORIZONTAL"
;; #:size "10x"
))
(tb
(iup:treebox
#:value 0
#:title "Runs" ;; was #:name -- iup 3.19 changed
;; this... "Changed: [DEPRECATED
;; REMOVED] removed the old attribute
;; NAMEid from IupTree to avoid
;; conflict with the common attribute
;; NAME. Use the TITLEid attribute."
#:expand "YES"
#:addexpanded "YES"
#:size "120x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (new-tree-path->run-id rdat (cdr run-path))))
;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
;; done below when run-id is a number
(dboard:rdat-targ-sql-filt-set! rdat (cdr run-path)) ;; (print
;; "run-path:
;; "
;; run-path)
(iup:attribute-set! txtbox "VALUE"
(string-intersperse (cdr run-path) "/"))
#;(dashboard:update-run-command tabdat)
#;(dboard:tabdat-layout-update-ok-set! tabdat #f)
(if (number? run-id)
(begin
;; capture last two in tabdat.
(dboard:rdat-push-run-id rdat run-id)
(dboard:rdat-view-changed-set! rdat #t))
(debug:print-error 5 *default-log-port* "tree-path->run-id returned non-number " run-id))))
"treebox"))
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:rdat-runs-tree-set! rdat tb)
(iup:detachbox
(iup:vbox
txtbox
tb
))))