@@ -92,10 +92,12 @@ (if (args:get-arg "-h") (begin (print help) (exit))) +;; TODO: Move this inside (main) +;; (if (not (launch:setup)) (begin (print "Failed to find megatest.config, exiting") (exit 1))) @@ -539,11 +541,11 @@ (let* ((db-dir (tasks:get-task-db-path)) (db-pth (conc db-dir "/" run-id ".db"))) (dboard:rundat-db-path-set! run-dat db-pth) db-pth))) (tmptests (if (or do-not-use-db-file-timestamps - (>= (file-modification-time db-path) last-update)) + (>= (common:lazy-modification-time db-path) last-update)) (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses (dboard:rundat-run-data-offset run-dat) num-to-get (dboard:tabdat-hide-not-hide tabdat) ;; no-in sort-by ;; sort-by @@ -1582,11 +1584,12 @@ runs) ht))) runs-hash)) (define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix) - (dashboard:do-update-rundat tabdat) + (if (dashboard:database-changed? commondat tabdat) + (dashboard:do-update-rundat tabdat)) (dboard:runs-summary-control-panel-updater tabdat) (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat)) (runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (runs (vector-ref runs-dat 1)) @@ -1596,11 +1599,12 @@ ;; (for-each (lambda (run) ;; (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) ;; runs) ;; ht)) ) - (dboard:update-tree tabdat runs-hash runs-header tb) + (if (dashboard:database-changed? commondat tabdat) + (dboard:update-tree tabdat runs-hash runs-header tb)) (if run-id (let* ((matrix-content (case (dboard:tabdat-runs-summary-mode tabdat) ((one-run) (dashboard:run-id->tests-mindat run-id tabdat runs-hash)) ((xor-two-runs) (dashboard:runs-summary-xor-matrix-content tabdat runs-hash)) @@ -2551,16 +2555,10 @@ (iup:attribute-set! *tim* "TIME" 300) (iup:attribute-set! *tim* "RUN" "YES") (define *last-recalc-ended-time* 0) -(define (dashboard:been-changed tabdat) - (> (file-modification-time (dboard:tabdat-dbfpath tabdat)) (dboard:tabdat-last-db-update tabdat))) - -(define (dashboard:set-db-update-time tabdat) - (dboard:tabdat-last-db-update-set! tabdat (file-modification-time (dboard:tabdat-dbfpath tabdat)))) - (define (dashboard:recalc modtime please-update-buttons last-db-update-time) (or please-update-buttons (and (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) (> modtime last-db-update-time) (> (current-seconds)(+ last-db-update-time 1))))) @@ -2596,13 +2594,16 @@ #f))) (define (dashboard:database-changed? commondat tabdat) (let* ((run-update-time (current-seconds)) (modtime (dashboard:get-youngest-run-db-mod-time tabdat)) ;; NOTE: ensure this is tabdat!! - (recalc (dashboard:recalc modtime (dboard:commondat-please-update commondat) (dboard:tabdat-last-db-update tabdat)))) - (dboard:commondat-please-update-set! commondat #f) - recalc)) + (recalc (dashboard:recalc modtime + (dboard:commondat-please-update commondat) + (dboard:tabdat-last-db-update tabdat)))) + (if recalc (dboard:tabdat-last-db-update-set! tabdat run-update-time)) + (dboard:commondat-please-update-set! commondat #f) + recalc)) ;; point inside line ;; (define-inline (dashboard:px-between px lx1 lx2) (and (< lx1 px)(> lx2 px))) @@ -2916,12 +2917,25 @@ (lambda (cf) (let* ((alldat (dboard:graph-read-data (cadr cf) tstart tend))) (if alldat (for-each (lambda (fieldn) - (let* ((dat (hash-table-ref alldat fieldn)) - (vals (map (lambda (x)(vector-ref x 2)) dat))) + (let*-values (((dat) (hash-table-ref alldat fieldn)) + ((vals minval maxval) (if (null? dat) + (values '() #f #f) + (let loop ((hed (car dat)) + (tal (cdr dat)) + (res '()) + (min (vector-ref (car dat) 2)) + (max (vector-ref (car dat) 2))) + (let* ((val (vector-ref hed 2)) + (newmin (if (< val min) val min)) + (newmax (if (> val max) val max)) + (newres (cons val res))) + (if (null? tal) + (values (reverse res) newmin newmax) + (loop (car tal)(cdr tal) newres newmin newmax))))))) (if (not (hash-table-exists? graph-matrix-table fieldn)) (begin (let* ((graph-color-rgb (vg:generate-color-rgb)) (graph-color (vg:iup-color->number graph-color-rgb)) (graph-matrix-col (dboard:tabdat-graph-matrix-col tabdat)) @@ -2944,12 +2958,12 @@ (dboard:tabdat-graph-matrix-col-set! tabdat 1) (dboard:tabdat-graph-matrix-row-set! tabdat (+ graph-matrix-row 1))) (dboard:tabdat-graph-matrix-col-set! tabdat (+ graph-matrix-col 1))) ))) (if (not (null? vals)) - (let* ((maxval (apply max vals)) - (minval (min 0 (apply min vals))) + (let* (;; (maxval (apply max vals)) + ;; (minval (min 0 (apply min vals))) (yoff (- minval lly)) ;; minval)) (deltaval (- maxval minval)) (yscale (/ delta-y (if (zero? deltaval) 1 deltaval))) (yfunc (lambda (y)(+ lly (* yscale (- y minval))))) ;; (lambda (y)(* (+ y yoff) yscale)))) (graph-dat (hash-table-ref graph-matrix-table fieldn)) @@ -3014,11 +3028,12 @@ (compact-layout (dboard:tabdat-compact-layout tabdat)) (row-height (if compact-layout 2 10)) (graph-height 120) (run-to-run-margin 25)) (dboard:tabdat-layout-update-ok-set! tabdat #t) - (if (canvas? cnv) + (if (and (canvas? cnv) + (not (null? allruns))) ;; allruns can go null when browsing the runs tree (let*-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv)) ((calc-y) (lambda (rownum) (- (/ sizey 2) (* rownum row-height)))) @@ -3337,87 +3352,90 @@ ;;====================================================================== ;; The heavy lifting starts here ;;====================================================================== +(define (main) + (let ((mtdb-path (conc *toppath* "/megatest.db"))) ;; + (if (and (file-exists? mtdb-path) + (file-write-access? mtdb-path)) + (if (not (args:get-arg "-skip-version-check")) + (let ((th1 (make-thread common:exit-on-version-changed))) + (thread-start! th1) + (if (> megatest-version (common:get-last-run-version-number)) + (debug:print-info 0 *default-log-port* "Version bump detected, blocking until db sync complete") + (thread-join! th1))))) + (let* ((commondat (dboard:commondat-make))) + ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... + (cond + ((args:get-arg "-test") ;; run-id,test-id + (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) + (if (> (length d) 1) + d + (list #f #f)))) + (run-id (car dat)) + (test-id (cadr dat))) + (if (and (number? run-id) + (number? test-id) + (>= test-id 0)) + (dashboard-tests:examine-test run-id test-id) + (begin + (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) + (exit 1))))) + ;; ((args:get-arg "-guimonitor") + ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) + (else + (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) + ;; (dboard:tabdat-numruns tabdat) + ;; (dboard:tabdat-num-tests tabdat) + ;; (dboard:tabdat-dbkeys tabdat) + ;; runs-sum-dat new-view-dat)) + ;; legacy setup of updaters for summary tab and runs tab + ;; summary tab + ;; (dboard:commondat-add-updater + ;; commondat + ;; (lambda () + ;; (dashboard:summary-tab-updater commondat 0)) + ;; tab-num: 0) + ;; runs tab + (dboard:commondat-curr-tab-num-set! commondat 0) + (dboard:commondat-add-updater + commondat + (lambda () + (dashboard:runs-tab-updater commondat 1)) + tab-num: 1) + (iup:callback-set! *tim* + "ACTION_CB" + (lambda (time-obj) + (let ((update-is-running #f)) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (set! update-is-running (dboard:commondat-updating commondat)) + (if (not update-is-running) + (dboard:commondat-updating-set! commondat #t)) + (mutex-unlock! (dboard:commondat-update-mutex commondat)) + (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update + (begin + (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) + (mutex-lock! (dboard:commondat-update-mutex commondat)) + (dboard:commondat-updating-set! commondat #f) + (mutex-unlock! (dboard:commondat-update-mutex commondat))) + )) + 1)))) + + (let ((th1 (make-thread (lambda () + (thread-sleep! 1) + (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab + ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. + ;; (dashboard:run-update commondat) + ) "update buttons once")) + (th2 (make-thread iup:main-loop "Main loop"))) + ;; (thread-start! th1) + (thread-start! th2) + (thread-join! th2))))) + ;; ease debugging by loading ~/.dashboardrc (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) -(define (main) - (if (not (args:get-arg "-skip-version-check")) - (let ((th1 (make-thread common:exit-on-version-changed))) - (thread-start! th1) - (if (> megatest-version (common:get-last-run-version-number)) - (debug:print-info 0 *default-log-port* "Version bump detected, blocking until db sync complete") - (thread-join! th1)))) - (let* ((commondat (dboard:commondat-make))) - ;; Move this stuff to db.scm? I'm not sure that is the right thing to do... - (cond - ((args:get-arg "-test") ;; run-id,test-id - (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) - (if (> (length d) 1) - d - (list #f #f)))) - (run-id (car dat)) - (test-id (cadr dat))) - (if (and (number? run-id) - (number? test-id) - (>= test-id 0)) - (dashboard-tests:examine-test run-id test-id) - (begin - (debug:print 3 *default-log-port* "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) - (exit 1))))) - ;; ((args:get-arg "-guimonitor") - ;; (gui-monitor (dboard:tabdat-dblocal tabdat))) - (else - (dboard:commondat-uidat-set! commondat (make-dashboard-buttons commondat)) ;; (dboard:tabdat-dblocal data) - ;; (dboard:tabdat-numruns tabdat) - ;; (dboard:tabdat-num-tests tabdat) - ;; (dboard:tabdat-dbkeys tabdat) - ;; runs-sum-dat new-view-dat)) - ;; legacy setup of updaters for summary tab and runs tab - ;; summary tab - ;; (dboard:commondat-add-updater - ;; commondat - ;; (lambda () - ;; (dashboard:summary-tab-updater commondat 0)) - ;; tab-num: 0) - ;; runs tab - (dboard:commondat-curr-tab-num-set! commondat 0) - (dboard:commondat-add-updater - commondat - (lambda () - (dashboard:runs-tab-updater commondat 1)) - tab-num: 1) - (iup:callback-set! *tim* - "ACTION_CB" - (lambda (time-obj) - (let ((update-is-running #f)) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (set! update-is-running (dboard:commondat-updating commondat)) - (if (not update-is-running) - (dboard:commondat-updating-set! commondat #t)) - (mutex-unlock! (dboard:commondat-update-mutex commondat)) - (if (not update-is-running) ;; we know that the update was not running and we now have a lock on doing an update - (begin - (dboard:common-run-curr-updaters commondat) ;; (dashboard:run-update commondat) - (mutex-lock! (dboard:commondat-update-mutex commondat)) - (dboard:commondat-updating-set! commondat #f) - (mutex-unlock! (dboard:commondat-update-mutex commondat))) - )) - 1)))) - - (let ((th1 (make-thread (lambda () - (thread-sleep! 1) - (dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab - ;; (dboard:commondat-please-update-set! commondat #t) ;; MRW: ww36.3 - why was please update set true here? Removing it for now. - ;; (dashboard:run-update commondat) - ) "update buttons once")) - (th2 (make-thread iup:main-loop "Main loop"))) - ;; (thread-start! th1) - (thread-start! th2) - (thread-join! th2)))) - (main)