Index: TODO
==================================================================
--- TODO
+++ TODO
@@ -16,11 +16,14 @@
# along with Megatest. If not, see .
TODO
====
-. Dashboard should resist running from non-homehost
+. Switch to using simple runs query everywhere
+. Add end_time to runs and add a rollup call that sets state, status and end_time
+
+
Migration to inmem db plus per run db
-------------------------------------
Index: api.scm
==================================================================
--- api.scm
+++ api.scm
@@ -58,10 +58,11 @@
get-target
;; register-run
get-tests-tags
get-test-times
get-tests-for-run
+ get-tests-for-run-state-status
get-test-id
get-tests-for-runs-mindata
get-tests-for-run-mindata
get-run-name-from-id
get-runs
@@ -292,10 +293,11 @@
((get-run-status) (apply db:get-run-status dbstruct params))
((get-run-state) (apply db:get-run-state dbstruct params))
((set-run-status) (apply db:set-run-status dbstruct params))
((set-run-state-status) (apply db:set-run-state-status dbstruct params))
((get-tests-for-run) (apply db:get-tests-for-run dbstruct params))
+ ((get-tests-for-run-state-status) (apply db:get-tests-for-run-state-status dbstruct params))
((get-test-id) (apply db:get-test-id dbstruct params))
((get-tests-for-run-mindata) (apply db:get-tests-for-run-mindata dbstruct params))
;; ((get-tests-for-runs-mindata) (apply db:get-tests-for-runs-mindata dbstruct params))
((get-runs) (apply db:get-runs dbstruct params))
((simple-get-runs) (apply db:simple-get-runs dbstruct params))
Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -431,10 +431,76 @@
((last-update 0) : number) ;; last query to db got records from before last-update
((last-db-time 0) : number) ;; last timestamp on megatest.db
((data-changed #f) : boolean)
((run-data-offset 0) : number) ;; get only 100 items per call, set back to zero when received less than 100 items
(db-path #f))
+
+;; for the new runs view lets build up a few new record types and then consolidate later
+;;
+;; this is a two level deep pipeline for the incoming data:
+;; sql query data ==> filters ==> data for display
+;;
+(defstruct dboard:rdat
+ ;; view related items
+ (runnum 0) ;; which column we are processing, index into runsbynum, we sweep across all these runs then start over
+ (leftcol 0) ;; number of the leftmost visible column
+ (toprow 0) ;; topmost visible row
+ (numcols 24) ;; number of columns visible
+ (numrows 20) ;; number of rows visible
+
+ ;; data from sql db
+ (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
+ (runs (make-sparse-vector)) ;; id => runrec
+ (runsbynum (make-vector 100 #f)) ;; vector num => runrec
+ (targ-runid (make-hash-table)) ;; area/target/runname => run-id ;; not sure this will be needed
+ (tests (make-hash-table)) ;; test[/itempath] => list of test rec
+
+ ;; run sql filters
+ (targ-sql-filt "%")
+ (runname-sql-filt "%")
+ (run-state-sql-filt "%")
+ (run-status-sql-filt "%")
+
+ ;; test sql filter
+ (testname-sql-filt "%")
+ (itempath-sql-filt "%")
+ (test-state-sql-filt "%")
+ (test-status-sql-filt "%")
+
+ ;; other sql related fields
+ (last-updates (make-sparse-vector 0)) ;; run-id -> timestamp of the last update from sql db, set to zero on any field changes
+
+ ;; filtered data
+ (cols (make-sparse-vector)) ;; columnnum => run-id
+ (tests (make-hash-table)) ;; test[/itempath] => (vector columnnum => test rec)
+
+ ;; various
+ (prev-run-ids '()) ;; push previously looked at runs on this
+ (view-changed #f)
+
+ ;; widgets
+ (runs-tree #f) ;;
+ )
+
+(define (dboard:rdat-push-run-id rdat run-id)
+ (dboard:rdat-prev-run-ids-set! rdat (cons run-id (dboard:rdat-prev-run-ids rdat))))
+
+(defstruct dboard:runrec
+ id
+ target ;; a/b/c...
+ tdef ;; for future use
+ )
+
+(defstruct dboard:testrec
+ id
+ runid
+ testname ;; test[/itempath]
+ state
+ status
+ start-time
+ duration
+ )
;; register dboard:rundat with BBpp
;; this is used by BBpp (Brandon's pretty printer) to convert dboard:rundat into a composition of lists that pp will handle
(hash-table-set! *BBpp_custom_expanders_list* RUNDAT:
(cons dboard:rundat?
@@ -1412,11 +1478,11 @@
(hash-table-set! tests-draw-state 'first-time #t)
;; (hash-table-set! tests-draw-state 'scalef 1)
(tests:get-full-data test-names test-records '() all-tests-registry)
(set! sorted-testnames (tests:sort-by-priority-and-waiton test-records))
- ;; refer to (dboard:tabdat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
+ ;; refer to (dboard:tabcodat-keys tabdat), (dboard:tabdat-dbkeys tabdat) for keys
(let* ((result
(iup:vbox
(dcommon:command-execution-control tabdat)
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
@@ -1456,40 +1522,53 @@
;; browse runs as a tree. Used in both "Runs" tab and
;; in the runs control panel.
;;
(define (dboard:runs-tree-browser commondat tabdat)
- (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:tabdat-target-set! tabdat (string-split b "/")))
- (dashboard:update-run-command tabdat))
- "command-testname-selector tb action"))
- #:value (dboard:test-patt->lines
- (dboard:tabdat-test-patts-use tabdat))
- #:expand "HORIZONTAL"
- ;; #:size "10x30"
- ))
+ (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:tabdat-target-set! tabdat
+ (string-split b "/")))
+ (dashboard:update-run-command tabdat))
+ "command-testname-selector tb action"))
+ #:value (dboard:test-patt->lines
+ (dboard:tabdat-test-patts-use tabdat))
+ #:expand "HORIZONTAL"
+ ;; #:size "10x30"
+ ))
(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."
+ #: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 "10x"
#:selection-cb
(lambda (obj id state)
(debug:catch-and-dump
(lambda ()
(let* ((run-path (tree:node->path obj id))
(run-id (tree-path->run-id tabdat (cdr run-path))))
- ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ?? done below when run-id is a number
- (dboard:tabdat-target-set! tabdat (cdr run-path)) ;; (print "run-path: " run-path)
- (iup:attribute-set! txtbox "VALUE" (string-intersperse (cdr run-path) "/"))
+ ;; (dboard:tabdat-view-changed-set! tabdat #t) ;; ??
+ ;; done below when run-id is a number
+ (dboard:tabdat-target-set! tabdat (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.
@@ -1503,12 +1582,80 @@
;; (print "path: " (tree:node->path obj id) " run-id: " run-id)
)))
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:detachbox
(iup:vbox
+ txtbox
+ tb
+ ))))
+
+;; 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-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 "10x30"
+ ))
+ (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 "10x"
+ #: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
- txtbox))))
+ ))))
;;======================================================================
;; R U N C O N T R O L S
;;======================================================================
;;
@@ -1674,10 +1821,15 @@
(define (tree-path->run-id tabdat path)
(if (not (null? path))
(hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f)
#f))
+
+(define (new-tree-path->run-id rdat path)
+ (if (not (null? path))
+ (hash-table-ref/default (dboard:rdat-path-run-ids tabdat) path #f)
+ #f))
;; (define (dboard:get-tests-dat tabdat run-id last-update)
;; (let* ((access-mode (dboard:tabdat-access-mode tabdat))
;; (tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
;; run-id
@@ -2428,14 +2580,164 @@
#:expand "HORIZONTAL"
#:max (* 10 (max (hash-table-size (dboard:tabdat-allruns-by-id tabdat)) 10))
#:min 0
#:step 0.01))
+;; make-simple-run procedure (target3772 id3773 runname3774 state3775 status3776 owner3777 event_time3778)
+;; rmt:simple-get-runs procedure (runpatt1001 count1002 offset1003 target1004)
+;; simple-run-event_time procedure (x3834)
+;; simple-run-event_time-set! procedure (x3830 val3831)
+;; simple-run-id procedure (x3794)
+;; simple-run-id-set! procedure (x3790 val3791)
+;; simple-run-owner procedure (x3826)
+;; simple-run-owner-set! procedure (x3822 val3823)
+;; simple-run-runname procedure (x3802)
+;; simple-run-runname-set! procedure (x3798 val3799)
+;; simple-run-state procedure (x3810)
+;; simple-run-state-set! procedure (x3806 val3807)
+;; simple-run-status procedure (x3818)
+;; simple-run-status-set! procedure (x3814 val3815)
+;; simple-run-target procedure (x3786)
+;; simple-run-target-set! procedure (x3782 val3783)
+;; simple-run? procedure (x3780)
+
+
+;;======================================================================
+;; 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
+;; 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)
+ ))
+ data)
+ numruns))
+
+;; 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
+ )))
+ (sparse-vector-set! (dboard:rdat-last-updates rdat) run-id (- curr-time 1))
+ (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)
+ (length tests)))
+
+(define (new-runs-updater commondat 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) 500)
+ (< 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))
+ ;; (tree:add-node tb "Runs" (string-split full-targ-runname "/"))
+ '()))
+
+(define (dboard:runs-new-matrix commondat rdat)
+ (iup:matrix
+ #:alignment1 "ALEFT"
+ ;; #:expand "YES" ;; "HORIZONTAL"
+ #:scrollbar "YES"
+ #:numcol 10
+ #:numlin 20
+ #:numcol-visible 5 ;; (min 8)
+ #:numlin-visible 1
+ #:click-cb
+ (lambda (obj row col status)
+ (let* ((cell (conc row ":" col)))
+ #f))
+ ))
+
+(define (make-runs-view commondat rdat tab-num)
+ ;; register an updater
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (new-runs-updater commondat rdat))
+ tab-num: tab-num)
+
+ (iup:vbox
+ (iup:split
+ #:orientation "VERTICAL" ;; "HORIZONTAL"
+ #:value 100
+ (dboard:runs-tree-new-browser commondat rdat)
+ (dboard:runs-new-matrix commondat rdat)
+ )))
(define (make-dashboard-buttons commondat) ;; runs-sum-dat new-view-dat)
(let* ((stats-dat (dboard:tabdat-make-data))
(runs-dat (dboard:tabdat-make-data))
+ (runs2-dat (make-dboard:rdat)) ;; (dboard:tabdat-make-data))
(onerun-dat (dboard:tabdat-make-data)) ;; name for run-summary structure
(runcontrols-dat (dboard:tabdat-make-data))
(runtimes-dat (dboard:tabdat-make-data))
(nruns (dboard:tabdat-numruns runs-dat))
(ntests (dboard:tabdat-num-tests runs-dat))
@@ -2477,26 +2779,32 @@
(let loop ((testnum 0)
(res '()))
(cond
((>= testnum ntests)
;; now lftlst will be an hbox with the test keys and the test name labels
- (set! lftlst (append lftlst (list (iup:hbox #:expand "HORIZONTAL"
- (iup:valuator #:valuechanged_cb (lambda (obj)
- (let ((val (string->number (iup:attribute obj "VALUE")))
- (oldmax (string->number (iup:attribute obj "MAX")))
- (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
- (dboard:commondat-please-update-set! commondat #t)
- (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
- (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) " (dboard:tabdat-start-test-offset runs-dat) " val: " val " newmax: " newmax " oldmax: " oldmax)
- (if (< val 10)
- (iup:attribute-set! obj "MAX" newmax))
- ))
- #:expand "VERTICAL"
- #:orientation "VERTICAL"
- #:min 0
- #:step 0.01)
- (apply iup:vbox (reverse res)))))))
+ (set! lftlst
+ (append lftlst
+ (list (iup:hbox
+ #:expand "HORIZONTAL"
+ (iup:valuator
+ #:valuechanged_cb (lambda (obj)
+ (let ((val (string->number (iup:attribute obj "VALUE")))
+ (oldmax (string->number (iup:attribute obj "MAX")))
+ (newmax (* 10 (length (dboard:tabdat-all-test-names runs-dat)))))
+ (dboard:commondat-please-update-set! commondat #t)
+ (dboard:tabdat-start-test-offset-set! runs-dat (inexact->exact (round (/ val 10))))
+ (debug:print 6 *default-log-port* "(dboard:tabdat-start-test-offset runs-dat) "
+ (dboard:tabdat-start-test-offset runs-dat) " val: " val
+ " newmax: " newmax " oldmax: " oldmax)
+ (if (< val 10)
+ (iup:attribute-set! obj "MAX" newmax))
+ ))
+ #:expand "VERTICAL"
+ #:orientation "VERTICAL"
+ #:min 0
+ #:step 0.01)
+ (apply iup:vbox (reverse res)))))))
(else
(let ((labl (iup:button "" ;; the testname labels
#:flat "YES"
#:alignment "ALEFT"
; #:image img1
@@ -2606,11 +2914,11 @@
(dashboard:runs-horizontal-slider runs-dat))))
controls
))
(views-cfgdat (common:load-views-config))
(additional-tabnames '())
- (tab-start-num 5) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
+ (tab-start-num 6) ;; DON'T FORGET TO UPDATE THIS WHEN CHANGING THE STANDARD TABS BELOW
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
(let ((tab-num tab-start-num)
(result '()))
(for-each
@@ -2648,22 +2956,24 @@
(dboard:commondat-please-update-set! commondat #t)
(dboard:tabdat-layout-update-ok-set! tabdat #t)))
"tabchangepos"))
(dashboard:summary commondat stats-dat tab-num: 0)
runs-view
- (dashboard:runs-summary commondat onerun-dat tab-num: 2)
+ (make-runs-view commondat runs2-dat 2)
+ (dashboard:runs-summary commondat onerun-dat tab-num: 3)
;; (dashboard:new-view db data new-view-dat tab-num: 3)
- (dashboard:run-controls commondat runcontrols-dat tab-num: 3)
- (dashboard:run-times commondat runtimes-dat tab-num: 4)
+ (dashboard:run-controls commondat runcontrols-dat tab-num: 4)
+ (dashboard:run-times commondat runtimes-dat tab-num: 5)
;; (dashboard:runs-summary commondat onerun-dat tab-num: 4)
additional-views)))
;; (set! (iup:callback tabs tabchange-cb:) (lambda (a b c)(print "SWITCHED TO TAB: " a " " b " " c)))
(iup:attribute-set! tabs "TABTITLE0" "Summary")
(iup:attribute-set! tabs "TABTITLE1" "Runs")
- (iup:attribute-set! tabs "TABTITLE2" "Run Summary")
- (iup:attribute-set! tabs "TABTITLE3" "Run Control")
- (iup:attribute-set! tabs "TABTITLE4" "Run Times")
+ (iup:attribute-set! tabs "TABTITLE2" "Runs2")
+ (iup:attribute-set! tabs "TABTITLE3" "Run Summary")
+ (iup:attribute-set! tabs "TABTITLE4" "Run Control")
+ (iup:attribute-set! tabs "TABTITLE5" "Run Times")
;; (iup:attribute-set! tabs "TABTITLE3" "New View")
;; (iup:attribute-set! tabs "TABTITLE4" "Run Control")
;; set the tab names for user added tabs
(for-each
@@ -3418,20 +3728,12 @@
(define (dashboard:runs-tab-updater commondat tab-num)
(debug:catch-and-dump
(lambda ()
(let* ((tabdat (dboard:common-get-tabdat commondat tab-num: tab-num))
(dbkeys (dboard:tabdat-dbkeys tabdat)))
- ;;(print "RA => calling runs-tab-updater with commondat " commondat " tab-num " tab-num)
- ;;(tabdat-values tabdat) ;;RA added
- ;; (pp (dboard:tabdat->alist tabdat))
- ;; (if (dashboard:database-changed? commondat tabdat context-key: 'runs-rundat)
(dashboard:do-update-rundat tabdat)
- ;;(debug:print-info 13 *default-log-port* "dashboard:runs-tab-updater")
- ;;(inspect tabdat)
-
(let ((uidat (dboard:commondat-uidat commondat)))
- ;;(print "RA => Calling update-buttons with tabdat : " tabdat " uidat " uidat)
(update-buttons tabdat uidat (dboard:tabdat-numruns tabdat) (dboard:tabdat-num-tests tabdat)))
))
"dashboard:runs-tab-updater"))
;;======================================================================
@@ -3469,10 +3771,15 @@
(dboard:commondat-add-updater
commondat
(lambda ()
(dashboard:runs-tab-updater commondat 1))
tab-num: 1)
+ (dboard:commondat-add-updater
+ commondat
+ (lambda ()
+ (dashboard:runs-tab-updater commondat 1))
+ tab-num: 2)
(iup:callback-set! *tim*
"ACTION_CB"
(lambda (time-obj)
(let ((update-is-running #f))
(mutex-lock! (dboard:commondat-update-mutex commondat))
Index: db.scm
==================================================================
--- db.scm
+++ db.scm
@@ -2072,10 +2072,14 @@
db
"SELECT fieldname FROM keys ORDER BY id DESC;")))
(set! *db-keys* res)
res)))
+;; extract index number given a header/data structure
+(define (db:get-index-by-header header field)
+ (list-index (lambda (x)(equal? x field)) header))
+
;; look up values in a header/data structure
(define (db:get-value-by-header row header field)
(if (or (null? header) (not row))
#f
(let loop ((hed (car header))
@@ -2258,11 +2262,11 @@
(fprintf out "#,(simple-run ~S ~S ~S ~S)"
(simple-run-target x) (simple-run-id x) (simple-run-runname x) (time->string (seconds->local-time (simple-run-event_time x) ))))
;; simple get-runs
;;
-(define (db:simple-get-runs dbstruct runpatt count offset target)
+(define (db:simple-get-runs dbstruct runpatt count offset target last-update)
(let* ((res '())
(keys (db:get-keys dbstruct))
(runpattstr (db:patt->like "runname" runpatt))
(remfields (list "id" "runname" "state" "status" "owner" "event_time"))
(targstr (string-intersperse keys "||'/'||"))
@@ -2269,17 +2273,22 @@
(keystr (conc targstr " AS target,"
(string-intersperse remfields ",")))
(qrystr (conc "SELECT " keystr " FROM runs WHERE (" runpattstr ") " ;; runname LIKE ? "
;; Generate: " AND x LIKE 'keypatt' ..."
" AND target LIKE '" target "'"
- " AND state != 'deleted' ORDER BY event_time DESC "
+ " AND state != 'deleted' "
+ (if (number? last-update)
+ (conc " AND last_update >= " last-update)
+ "")
+ " ORDER BY event_time DESC "
(if (number? count)
(conc " LIMIT " count)
"")
(if (number? offset)
(conc " OFFSET " offset)
- ""))))
+ "")))
+ )
(debug:print-info 11 *default-log-port* "db:get-runs START qrystr: " qrystr " target: " target " offset: " offset " limit: " count)
(db:with-db dbstruct #f #f
(lambda (db)
(sqlite3:for-each-row
(lambda (target id runname state status owner event_time)
@@ -2872,11 +2881,11 @@
(vector-ref inrec 5) ;; status
-1 "" -1 -1 "" "-"
(vector-ref inrec 3) ;; item-path
-1 "-" "-"))
-(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
+#;(define (db:get-tests-for-run-state-status dbstruct run-id testpatt)
(let* ((res '())
(tests-match-qry (tests:match->sqlqry testpatt))
(qry (conc "SELECT id,testname,item_path,state,status FROM tests WHERE run_id=? "
(if tests-match-qry (conc " AND (" tests-match-qry ") ") ""))))
(debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
@@ -2888,10 +2897,30 @@
(set! res (cons (vector id run-id testname state status -1 "" -1 -1 "" "-" item-path -1 "-" "-") res)))
db
qry
run-id)))
res))
+
+(define (db:get-tests-for-run-state-status dbstruct run-id testpatt #!optional (last-update 0))
+ (let* ((res '())
+ (tests-match-qry (tests:match->sqlqry testpatt))
+ (qry (conc "SELECT id,testname,item_path,state,status,event_time,run_duration FROM tests WHERE run_id=? "
+ " AND last_update > ? "
+ (if tests-match-qry (conc " AND (" tests-match-qry ") ") "")
+ )))
+ (debug:print-info 8 *default-log-port* "db:get-tests-for-run qry=" qry)
+ (db:with-db dbstruct run-id #f
+ (lambda (db)
+ (sqlite3:fold-row
+ (lambda (res id testname item-path state status event-time run-duration)
+ ;; id,run_id,testname,state,status,event_time,host,cpuload,diskfree,uname,rundir,item_path,run_duration,final_logf,comment
+ (cons (vector id run-id testname state status event-time "" -1 -1 "" "-" item-path run-duration "-" "-") res))
+ '()
+ db
+ qry
+ run-id
+ (or last-update 0))))))
(define (db:get-testinfo-state-status dbstruct run-id test-id)
(let ((res #f))
(db:with-db dbstruct run-id #f
(lambda (db)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -558,10 +558,13 @@
;; (begin
;; (debug:print-error 0 *default-log-port* "rmt:get-tests-for-run called with bad run-id=" run-id)
;; (print-call-chain (current-error-port))
;; '())))
+(define (rmt:get-tests-for-run-state-status run-id testpatt last-update)
+ (rmt:send-receive 'get-tests-for-run-state-status run-id (list run-id testpatt last-update)))
+
;; get stuff via synchash
(define (rmt:synchash-get run-id proc synckey keynum params)
(rmt:send-receive 'synchash-get run-id (list run-id proc synckey keynum params)))
(define (rmt:get-tests-for-run-mindata run-id testpatt states status not-in)
@@ -735,12 +738,12 @@
(rmt:send-receive 'delete-old-deleted-test-records #f '()))
(define (rmt:get-runs runpatt count offset keypatts)
(rmt:send-receive 'get-runs #f (list runpatt count offset keypatts)))
-(define (rmt:simple-get-runs runpatt count offset target)
- (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target)))
+(define (rmt:simple-get-runs runpatt count offset target last-update)
+ (rmt:send-receive 'simple-get-runs #f (list runpatt count offset target last-update)))
(define (rmt:get-all-run-ids)
(rmt:send-receive 'get-all-run-ids #f '()))
(define (rmt:get-prev-run-ids run-id)
Index: runs.scm
==================================================================
--- runs.scm
+++ runs.scm
@@ -2012,11 +2012,11 @@
(let* ((targets (string-split target-patts ","))
(keys (rmt:get-keys))
(res-ht (make-hash-table))) ;; target -> ( runrecord1 runrecord2 ... )
(for-each
(lambda (target-patt)
- (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt)))
+ (let ((runs (rmt:simple-get-runs runpatt #f #f target-patt #f)))
(for-each
(lambda (run)
(let ((target (simple-run-target run)))
(hash-table-set! res-ht target (cons run (hash-table-ref/default res-ht target '())))))
runs)))