Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -95,10 +95,14 @@ (define *examine-test-dat* (make-hash-table)) (define *exit-started* #f) (define *status-ignore-hash* (make-hash-table)) (define *state-ignore-hash* (make-hash-table)) +(define *last-db-update-time* 0) +(define *please-update-buttons* #t) +(define *db-file-path* (conc *toppath* "/megatest.db")) + (define *verbosity* (cond ((args:get-arg "-debug")(string->number (args:get-arg "-debug"))) ((args:get-arg "-v") 2) ((args:get-arg "-q") 0) (else 1))) @@ -181,36 +185,42 @@ (delta (map (lambda (a b)(abs (- a b))) c1 c2))) (null? (filter (lambda (x)(> x 3)) delta)))) ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat runnamepatt numruns testnamepatt itemnamepatt keypatts) - (let* ((allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - *start-run-offset* keypatts)) - (header (db:get-header allruns)) - (runs (db:get-rows allruns)) - (result '()) - (maxtests 0) - (states (hash-table-keys *state-ignore-hash*)) - (statuses (hash-table-keys *status-ignore-hash*))) - ;; Instead of this mechanism lets try setting number of runs based on "result" below - (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes - (begin - (set! *last-update* (current-seconds)) - (set! *tot-run-count* (db:get-num-runs *db* runnamepatt)))) - (for-each (lambda (run) - (let* ((run-id (db:get-value-by-header run header "id")) - (tests (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses)) - (key-vals (get-key-vals *db* run-id))) - (if (> (length tests) maxtests) - (set! maxtests (length tests))) - (if (not (null? tests)) - (set! result (cons (vector run tests key-vals) result))))) - runs) - (set! *header* header) - (set! *allruns* result) - ;; (set! *tot-run-count* (+ 1 (length *allruns*))) - maxtests)) + (let ((modtime (file-modification-time *db-file-path*))) + (if (> modtime *last-db-update-time*) + (begin + (set! *please-update-buttons* #t) + (set! *last-db-update-time* modtime) + (let* ((allruns (db:get-runs *db* runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) + *start-run-offset* keypatts)) + (header (db:get-header allruns)) + (runs (db:get-rows allruns)) + (result '()) + (maxtests 0) + (states (hash-table-keys *state-ignore-hash*)) + (statuses (hash-table-keys *status-ignore-hash*))) + ;; Instead of this mechanism lets try setting number of runs based on "result" below + (if (> (+ *last-update* 300) (current-seconds)) ;; every five minutes + (begin + (set! *last-update* (current-seconds)) + (set! *tot-run-count* (db:get-num-runs *db* runnamepatt)))) + (for-each (lambda (run) + (let* ((run-id (db:get-value-by-header run header "id")) + (tests (db-get-tests-for-run *db* run-id testnamepatt itemnamepatt states statuses)) + (key-vals (get-key-vals *db* run-id))) + (if (> (length tests) maxtests) + (set! maxtests (length tests))) + (if (not (null? tests)) + (set! result (cons (vector run tests key-vals) result))))) + runs) + (set! *header* header) + (set! *allruns* result) + ;; (set! *tot-run-count* (+ 1 (length *allruns*))) + maxtests)) + *num-tests*))) ;; FIXME, naughty coding eh? (define *collapsed* (make-hash-table)) ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) @@ -321,99 +331,101 @@ ((KILLED) "234 101 17") ((NOT_STARTED) "240 240 240") (else "192 192 192"))) (define (update-buttons uidat numruns numtests) - (let* ((runs (if (> (length *allruns*) numruns) - (take-right *allruns* numruns) - (pad-list *allruns* numruns))) - (lftcol (vector-ref uidat 0)) - (tableheader (vector-ref uidat 1)) - (table (vector-ref uidat 2)) - (coln 0)) - (set! *alltestnamelst* '()) - ;; create a concise list of test names - (for-each - (lambda (rundat) - (if (vector? rundat) - (let* ((testdat (vector-ref rundat 1)) - (testnames (map test:test-get-fullname testdat))) - (for-each (lambda (testname) - (if (not (member testname *alltestnamelst*)) - (begin - (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) - testnames)))) - runs) - - (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness - (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) - (drop *alltestnamelst* *start-test-offset*) - '()))) - (append xl (make-list (- *num-tests* (length xl)) "")))) - (update-labels uidat) - (for-each - (lambda (rundat) - (if (not rundat) ;; handle padded runs - ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration - (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) - (let* ((run (vector-ref rundat 0)) - (testsdat (vector-ref rundat 1)) - (key-val-dat (vector-ref rundat 2)) - (run-id (db:get-value-by-header run *header* "id")) - (key-vals (append key-val-dat - (list (let ((x (db:get-value-by-header run *header* "runname"))) - (if x x ""))))) - (run-key (string-intersperse key-vals "\n"))) - - ;; fill in the run header key values - (let ((rown 0) - (headercol (vector-ref tableheader coln))) - (for-each (lambda (kval) - (let* ((labl (vector-ref headercol rown))) - (if (not (equal? kval (iup:attribute labl "TITLE"))) - (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) - (set! rown (+ rown 1)))) - key-vals)) - - ;; For this run now fill in the buttons for each test - (let ((rown 0) - (columndat (vector-ref table coln))) - (for-each - (lambda (testname) - (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) - (if buttondat - (let* ((test (let ((matching (filter - (lambda (x)(equal? (test:test-get-fullname x) testname)) - testsdat))) - (if (null? matching) - (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") - (car matching)))) - (testname (db:test-get-testname test)) - (itempath (db:test-get-item-path test)) - (testfullname (test:test-get-fullname test)) - (teststatus (db:test-get-status test)) - (teststate (db:test-get-state test)) - (teststart (db:test-get-event_time test)) - (runtime (db:test-get-run_duration test)) - (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) - (button (vector-ref columndat rown)) - (color (get-color-for-state-status teststate teststatus)) - (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) - (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) - (if (not (equal? curr-color color)) - (iup:attribute-set! button "BGCOLOR" color)) - (if (not (equal? curr-title buttontxt)) - (iup:attribute-set! button "TITLE" buttontxt)) - (vector-set! buttondat 0 run-id) - (vector-set! buttondat 1 color) - (vector-set! buttondat 2 buttontxt) - (vector-set! buttondat 3 test) - (vector-set! buttondat 4 run-key))) - (set! rown (+ rown 1)))) - *alltestnamelst*)) - (set! coln (+ coln 1)))) - runs))) + (if *please-update-buttons* + (let* ((runs (if (> (length *allruns*) numruns) + (take-right *allruns* numruns) + (pad-list *allruns* numruns))) + (lftcol (vector-ref uidat 0)) + (tableheader (vector-ref uidat 1)) + (table (vector-ref uidat 2)) + (coln 0)) + (set! *please-update-buttons* #f) + (set! *alltestnamelst* '()) + ;; create a concise list of test names + (for-each + (lambda (rundat) + (if (vector? rundat) + (let* ((testdat (vector-ref rundat 1)) + (testnames (map test:test-get-fullname testdat))) + (for-each (lambda (testname) + (if (not (member testname *alltestnamelst*)) + (begin + (set! *alltestnamelst* (append *alltestnamelst* (list testname)))))) + testnames)))) + runs) + + (set! *alltestnamelst* (collapse-rows *alltestnamelst*)) ;;; argh. please clean up this sillyness + (set! *alltestnamelst* (let ((xl (if (> (length *alltestnamelst*) *start-test-offset*) + (drop *alltestnamelst* *start-test-offset*) + '()))) + (append xl (make-list (- *num-tests* (length xl)) "")))) + (update-labels uidat) + (for-each + (lambda (rundat) + (if (not rundat) ;; handle padded runs + ;; ;; id run-id testname state status event-time host cpuload diskfree uname rundir item-path run-duration + (set! rundat (vector (make-vector 20 #f) '() (map (lambda (x) "") *keys*))));; 3))) + (let* ((run (vector-ref rundat 0)) + (testsdat (vector-ref rundat 1)) + (key-val-dat (vector-ref rundat 2)) + (run-id (db:get-value-by-header run *header* "id")) + (key-vals (append key-val-dat + (list (let ((x (db:get-value-by-header run *header* "runname"))) + (if x x ""))))) + (run-key (string-intersperse key-vals "\n"))) + + ;; fill in the run header key values + (let ((rown 0) + (headercol (vector-ref tableheader coln))) + (for-each (lambda (kval) + (let* ((labl (vector-ref headercol rown))) + (if (not (equal? kval (iup:attribute labl "TITLE"))) + (iup:attribute-set! (vector-ref headercol rown) "TITLE" kval)) + (set! rown (+ rown 1)))) + key-vals)) + + ;; For this run now fill in the buttons for each test + (let ((rown 0) + (columndat (vector-ref table coln))) + (for-each + (lambda (testname) + (let ((buttondat (hash-table-ref/default *buttondat* (mkstr coln rown) #f))) + (if buttondat + (let* ((test (let ((matching (filter + (lambda (x)(equal? (test:test-get-fullname x) testname)) + testsdat))) + (if (null? matching) + (vector -1 -1 "" "" "" 0 "" "" 0 "" "" "" 0 "" "") + (car matching)))) + (testname (db:test-get-testname test)) + (itempath (db:test-get-item-path test)) + (testfullname (test:test-get-fullname test)) + (teststatus (db:test-get-status test)) + (teststate (db:test-get-state test)) + (teststart (db:test-get-event_time test)) + (runtime (db:test-get-run_duration test)) + (buttontxt (if (equal? teststate "COMPLETED") teststatus teststate)) + (button (vector-ref columndat rown)) + (color (get-color-for-state-status teststate teststatus)) + (curr-color (vector-ref buttondat 1)) ;; (iup:attribute button "BGCOLOR")) + (curr-title (vector-ref buttondat 2))) ;; (iup:attribute button "TITLE"))) + (if (not (equal? curr-color color)) + (iup:attribute-set! button "BGCOLOR" color)) + (if (not (equal? curr-title buttontxt)) + (iup:attribute-set! button "TITLE" buttontxt)) + (vector-set! buttondat 0 run-id) + (vector-set! buttondat 1 color) + (vector-set! buttondat 2 buttontxt) + (vector-set! buttondat 3 test) + (vector-set! buttondat 4 run-key))) + (set! rown (+ rown 1)))) + *alltestnamelst*)) + (set! coln (+ coln 1)))) + runs)))) (define (mkstr . x) (string-intersperse (map conc x) ",")) (define (update-search x val) @@ -507,10 +519,11 @@ (hash-table-delete! *state-ignore-hash* "KILLED"))))))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (+ 0.0 (string->number (iup:attribute obj "VALUE")))))) (maxruns *tot-run-count*)) ;;; (+ *num-runs* (length *allruns*)))) (set! *start-run-offset* val) + (set! *last-db-update-time* 0) (debug:print 3 "maxruns: " maxruns ", val: " val) (iup:attribute-set! obj "MAX" maxruns))) #:expand "YES" #:max (+ ;; *num-runs* (length *allruns*))) @@ -538,10 +551,11 @@ ((>= testnum ntests) ;; now lftlst will be an hbox with the test keys and the test name labels (set! lftlst (append lftlst (list (iup:hbox (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (iup:attribute obj "VALUE"))) + (set! *please-update-buttons* #t) (set! *start-test-offset* (inexact->exact (round (string->number val)))) (iup:attribute-set! obj "MAX" (length *alltestnamelst*)) ) ) #:expand "YES" #:orientation "VERTICAL")