Index: dashboard.scm
==================================================================
--- dashboard.scm
+++ dashboard.scm
@@ -431,10 +431,62 @@
((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
+ ;; data from sql db
+ (keys (rmt:get-keys)) ;; to be removed when targets handling is refactored
+ (runs (make-sparse-vector)) ;; id => runrec
+ (targ-runid (make-hash-table)) ;; target/runname => run-id
+ (tests (make-hash-table)) ;; test[/itempath] => list of test rec
+
+ ;; sql filters
+ targ-sql-filt
+ runname-sql-filt
+ state-sql-filt
+ status-sql-filt
+
+ ;; other sql related fields
+ (last-update 0) ;; timestamp of the last update from sql db, set to zero on any field changes
+
+ ;; filtered data
+ (cols (make-sparse-vector))
+ (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 +1464,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 +1508,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 +1568,78 @@
;; (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.
+;;
+(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 +1805,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 +2564,86 @@
#: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)
+
+;; runs is <vec header runs>
+;;
+(define (dashboard:update-runs-data data rdat)
+ ;; update runs id => runrec
+ ;; update targ-runid target/runname => run-id
+ (for-each
+ (lambda (runrec)
+ (let* ((run-id (simple-run-id runrec)))
+ (sparse-vector-set! (dboard:rdat-runs rdat) run-id runrec)
+ (hash-table-set! (dboard:rdat-targ-runid rdat)
+ (conc (simple-run-target runrec) "/" (simple-run-runname runrec))
+ run-id)))
+ data))
+
+(define (new-runs-updater commondat rdat)
+ (let* ((last-update (dboard:rdat-last-update rdat))
+ (targ-sql-filt (dboard:rdat-targ-sql-filt rdat))
+ (runname-sql-filt (dboard:rdat-runname-sql-filt rdat))
+ (state-sql-filt (dboard:rdat-state-sql-filt rdat))
+ (status-sql-filt (dboard:rdat-status-sql-filt rdat))
+ ;; Use (db:get-value-by-header (db:get-header runinfo)(db:get-rows runinfo))
+ (newdata (rmt:simple-get-runs runname-sql-filt #f #f targ-sql-filt last-update)))
+ (dashboard:update-runs-data newdata rdat)
+ (dboard:rdat-last-update-set! rdat (- (current-seconds) 10))
+ '()))
+
+(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)
+ (iup:vbox (iup:button "Pushme"))
+ #;(iup:split
+ #:value 100
+ ;; left most block, including row names
+ ;; (apply iup:vbox lftlst)
+ ;; right hand block, including cells
+ (iup:vbox
+ #:expand "YES"
+ ;; the header
+ (apply iup:hbox (reverse hdrlst))
+ (apply iup:hbox (reverse bdylst))
+ (dashboard:runs-horizontal-slider runs-dat))))
+ ;; controls
+ ))
(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 +2685,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 +2820,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 +2862,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 +3634,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 +3677,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
@@ -2026,10 +2026,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))
@@ -2212,11 +2216,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 "||'/'||"))
@@ -2223,17 +2227,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)
Index: rmt.scm
==================================================================
--- rmt.scm
+++ rmt.scm
@@ -735,12 +735,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)))