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,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 +1807,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 +2566,89 @@ #: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 +;; +(define (dashboard:update-runs-data data rdat) + (let* ((tb (dboard:rdat-runs-tree rdat))) + ;; 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)))) + (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))) + +(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 +2690,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 +2825,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 +2867,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 +3639,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 +3682,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)))