Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -41,11 +41,11 @@ (include "db_records.scm") (include "run_records.scm") (include "megatest-fossil-hash.scm") (define help (conc -"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest + "Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version " license GPL, Copyright (C) Matt Welland 2012-2016 Usage: dashboard [options] -h : this help @@ -72,11 +72,11 @@ "-guimonitor" "-main" "-v" "-q" "-use-local" - ) + ) args:arg-hash 0)) (if (args:get-arg "-h") (begin @@ -97,10 +97,11 @@ curr-tab-num dbdir dbfpath dbkeys dblocal + filters-changed header hide-empty-runs hide-not-hide ;; toggle for hide/not hide hide-not-hide-button hide-not-hide-tabs @@ -119,11 +120,11 @@ tot-runs update-mutex updaters updating useserver - ) + ) (define *alldat* (make-d:alldat header: #f allruns: '() allruns-by-id: (make-hash-table) @@ -144,10 +145,11 @@ hide-not-hide: #t hide-not-hide-button: #f hide-not-hide-tabs: #f curr-tab-num: 0 updaters: (make-hash-table) + filters-changed: #f )) ;; simple two dimentional sparse array ;; (define (make-sparse-array) @@ -347,19 +349,19 @@ (string>? item-path1 item-path2) test1-older) (if same-time (string>? test-name1 test-name2) test1-older)))) - + ;; create a virtual table of all the tests ;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") ) (define (update-rundat data runnamepatt numruns testnamepatt keypatts) (let* ((referenced-run-ids '()) (allruns (if (d:alldat-useserver data) (rmt:get-runs runnamepatt numruns (d:alldat-start-run-offset data) keypatts) (db:get-runs (d:alldat-dblocal data) runnamepatt numruns ;; (+ numruns 1) ;; (/ numruns 2)) - (d:alldat-start-run-offset data) keypatts))) + (d:alldat-start-run-offset data) keypatts))) (header (db:get-header allruns)) (runs (db:get-rows allruns)) (result '()) (maxtests 0) (states (hash-table-keys (d:alldat-state-ignore-hash data))) @@ -402,12 +404,12 @@ (not (equal? (db:test-get-state x) "DELETED"))) ;; remove deleted tests but do it after merging (delete-duplicates (append tmptests prev-tests) (lambda (a b) (eq? (db:test-get-id a)(db:test-get-id b))))))) (if (eq? *tests-sort-reverse* 3) ;; +event_time - (sort newdat compare-tests) - newdat)))) + (sort newdat compare-tests) + newdat)))) ;; NOTE: bubble-up also sets the global (d:alldat-item-test-names data) ;; (tests (bubble-up tmptests priority: bubble-type)) ;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively. ;; (debug:print 0 "Getting data for run " run-id " with key-vals=" key-vals) ;; Not sure this is needed? @@ -425,26 +427,26 @@ (d:alldat-allruns-set! data result) (debug:print-info 6 "(d:alldat-allruns data) has " (length (d:alldat-allruns data)) " runs") maxtests)) (define *collapsed* (make-hash-table)) -; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) + ; (define *row-lookup* (make-hash-table)) ;; testname => (rownum lableobj) (define (toggle-hide lnum) ; fulltestname) (let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum)) (fulltestname (iup:attribute btn "TITLE")) (parts (string-split fulltestname "(")) (basetestname (if (null? parts) "" (car parts)))) - ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) + ;(print "Toggling " basetestname " currently " (hash-table-ref/default *collapsed* basetestname #f)) (if (hash-table-ref/default *collapsed* basetestname #f) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") + ;(iup:attribute-set! btn "FGCOLOR" "0 0 0") (hash-table-delete! *collapsed* basetestname)) (begin - ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") + ;(iup:attribute-set! btn "FGCOLOR" "0 192 192") (hash-table-set! *collapsed* basetestname #t))))) - + (define blank-line-rx (regexp "^\\s*$")) (define (run-item-name->vectors lst) (map (lambda (x) (let ((splst (string-split x "(")) @@ -479,11 +481,11 @@ (map (lambda (x) (if (equal? (vector-ref x 1) "") (vector-ref x 0) (conc (vector-ref x 0) "(" (vector-ref x 1) ")"))) vlst2))) - + (define (update-labels uidat) (let* ((rown 0) (keycol (dboard:uidat-get-keycol uidat)) (lftcol (dboard:uidat-get-lftcol uidat)) (numcols (vector-length lftcol)) @@ -564,11 +566,11 @@ (res '())) (let ((newres (append res (hash-table-ref tests hed)))) (if (null? tal) newres (loop (car tal)(cdr tal) newres)))))))) - + (define (update-buttons uidat numruns numtests) (let* ((runs (if (> (length (d:alldat-allruns *alldat*)) numruns) (take-right (d:alldat-allruns *alldat*) numruns) (pad-list (d:alldat-allruns *alldat*) numruns))) (lftcol (dboard:uidat-get-lftcol uidat)) @@ -683,10 +685,11 @@ "190 190 190" )))) (define (update-search x val) (hash-table-set! (d:alldat-searchpatts *alldat*) x val) + (d:alldat-set-filters-changed! *alldat* #t) (set-bg-on-filter)) (define (mark-for-update) (d:alldat-last-db-update-set! *alldat* 0)) @@ -827,11 +830,12 @@ (conc " :status " (string-intersperse statuses ",")))) (full-cmd "megatest")) (case (string->symbol cmd) ((runtests) (set! full-cmd (conc full-cmd - " -runtests " + " -run" + " -testpatt " test-patt " -target " target " -runname " run-name @@ -855,22 +859,22 @@ (define (dashboard:draw-tests cnv xadj yadj tests-draw-state sorted-testnames test-records) (canvas-clear! cnv) (canvas-font-set! cnv "Helvetica, -10") (let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv)) ((originx originy) (canvas-origin cnv))) - ;; (print "originx: " originx " originy: " originy) - ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) - (if (hash-table-ref/default tests-draw-state 'first-time #t) - (begin - (hash-table-set! tests-draw-state 'first-time #f) - (hash-table-set! tests-draw-state 'scalef 1) - (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) - (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) - ;; set these - (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) - )) + ;; (print "originx: " originx " originy: " originy) + ;; (canvas-origin-set! cnv 0 (- (/ sizey 2))) + (if (hash-table-ref/default tests-draw-state 'first-time #t) + (begin + (hash-table-set! tests-draw-state 'first-time #f) + (hash-table-set! tests-draw-state 'scalef 1) + (hash-table-set! tests-draw-state 'tests-info (make-hash-table)) + (hash-table-set! tests-draw-state 'selected-tests (make-hash-table)) + ;; set these + (dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + (dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records)) + )) ;;====================================================================== ;; R U N C O N T R O L S ;;====================================================================== ;; @@ -888,13 +892,17 @@ (key-listboxes #f) (updater-for-runs #f) (update-keyvals (lambda () (let ((targ (map (lambda (x) (iup:attribute x "VALUE")) - (car (dashboard:update-target-selector key-listboxes))))) + (car (dashboard:update-target-selector key-listboxes)))) + (curr-runname (dboard:data-get-run-name *data*))) (dboard:data-set-target! *data* targ) (if updater-for-runs (updater-for-runs)) + (if (or (not (equal? curr-runname (dboard:data-get-run-name *data*))) + (equal? (dboard:data-get-run-name *data*) "")) + (dboard:data-set-run-name! *data* curr-runname)) (dashboard:update-run-command)))) (tests-draw-state (make-hash-table)) ;; use for keeping state of the test canvas (test-patterns-textbox #f)) (hash-table-set! tests-draw-state 'first-time #t) ;; (hash-table-set! tests-draw-state 'scalef 1) @@ -959,17 +967,19 @@ (tb (iup:textbox #:expand "HORIZONTAL" #:action (lambda (obj val txt) ;; (print "obj: " obj " val: " val " unk: " unk) (dboard:data-set-run-name! *data* txt) ;; (iup:attribute obj "VALUE")) (dashboard:update-run-command)) - #:value default-run-name)) + #:value (or default-run-name (dboard:data-get-run-name *data*)))) (lb (iup:listbox #:expand "HORIZONTAL" #:dropdown "YES" #:action (lambda (obj val index lbstate) - (iup:attribute-set! tb "VALUE" val) - (dboard:data-set-run-name! *data* val) - (dashboard:update-run-command)))) + (if (not (equal? val "")) + (begin + (iup:attribute-set! tb "VALUE" val) + (dboard:data-set-run-name! *data* val) + (dashboard:update-run-command)))))) (refresh-runs-list (lambda () (let* ((target (dboard:data-get-target-string *data*)) (runs-for-targ (if (d:alldat-useserver *alldat*) (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" target #f #f #f) (db:get-runs-by-patt (d:alldat-dblocal *alldat*) (d:alldat-keys *alldat*) "%" target #f #f #f))) @@ -977,11 +987,11 @@ (runs-dat (vector-ref runs-for-targ 1)) (run-names (cons default-run-name (map (lambda (x) (db:get-value-by-header x runs-header "runname")) runs-dat)))) - (iup:attribute-set! lb "REMOVEITEM" "ALL") + ;; (iup:attribute-set! lb "REMOVEITEM" "ALL") (iuplistbox-fill-list lb run-names selected-item: default-run-name))))) (set! updater-for-runs refresh-runs-list) (refresh-runs-list) (dboard:data-set-run-name! *data* default-run-name) (iup:hbox @@ -1031,11 +1041,11 @@ (dashboard:text-list-toggle-box (map cadr *common:std-statuses*) ;; '("PASS" "FAIL" "n/a" "CHECK" "WAIVED" "SKIP" "DELETED" "STUCK/DEAD") (lambda (all) (dboard:data-set-statuses! *data* all) (dashboard:update-run-command)))))))) - + (iup:frame #:title "Tests and Tasks" (let* ((updater #f) (last-xadj 0) (last-yadj 0) @@ -1067,14 +1077,14 @@ #:scrollbar "YES" #:posx "0.5" #:posy "0.5" #:button-cb (lambda (obj btn pressed x y status) ;; (print "obj: " obj ", pressed " pressed ", status " status) - ; (print "canvas-origin: " (canvas-origin the-cnv)) + ; (print "canvas-origin: " (canvas-origin the-cnv)) ;; (let-values (((xx yy)(canvas-origin the-cnv))) - ;; (canvas-transform-set! the-cnv #f) - ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) + ;; (canvas-transform-set! the-cnv #f) + ;; (print "canvas-origin: " xx " " yy " click at " x " " y)) (let* ((tests-info (hash-table-ref tests-draw-state 'tests-info)) (selected-tests (hash-table-ref tests-draw-state 'selected-tests)) (scalef (hash-table-ref tests-draw-state 'scalef)) (sizey (hash-table-ref tests-draw-state 'sizey)) (xoffset (dcommon:get-xoffset tests-draw-state #f #f)) @@ -1107,11 +1117,11 @@ (dboard:data-set-test-patts! *data* (dboard:lines->test-patt newpatt)) (dashboard:update-run-command) (if updater (updater last-xadj last-yadj))))))) (hash-table-keys tests-info))))))) canvas-obj))) - + (iup:frame #:title "Logs" ;; To be replaced with tabs (let ((logs-tb (iup:textbox #:expand "YES" #:multiline "YES"))) (dboard:data-set-logs-textbox! *data* logs-tb) @@ -1191,83 +1201,90 @@ (hash-table-ref/default (d:data-path-run-ids data) path #f) #f)) (define dashboard:update-run-summary-tab #f) +(define (dboard:get-tests-dat data run-id last-update) + (let ((tdat (if run-id + (if (d:alldat-useserver data) + (rmt:get-tests-for-run run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update)) ;; get 'em all + (db:get-tests-for-run db run-id + (hash-table-ref/default (d:alldat-searchpatts data) "test-name" "%/%") + (hash-table-keys (d:alldat-state-ignore-hash data)) ;; '() + (hash-table-keys (d:alldat-status-ignore-hash data)) ;; '() + #f #f + (d:alldat-hide-not-hide data) + #f #f + "id,testname,item_path,state,status" + (if (d:alldat-filters-changed data) + 0 + last-update))) + '()))) ;; get 'em all + (sort tdat (lambda (a b) + (let* ((aval (vector-ref a 2)) + (bval (vector-ref b 2)) + (anum (string->number aval)) + (bnum (string->number bval))) + (if (and anum bnum) + (< anum bnum) + (string<= aval bval))))))) + ;; This is the Run Summary tab ;; -(define (dashboard:one-run db data) +(define (dashboard:one-run db data ddata) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! data run-id) + (d:data-curr-run-id-set! ddata run-id) (dashboard:update-run-summary-tab)) (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) + (tests-dat (dboard:get-tests-dat data run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1280,31 +1297,32 @@ (record-b (hash-table-ref runs-hash b)) (time-a (db:get-value-by-header record-a runs-header "event_time")) (time-b (db:get-value-by-header record-b runs-header "event_time"))) (< time-a time-b)))))) + (d:alldat-filters-changed-set! data #f) ;; (iup:attribute-set! tb "VALUE" "0") ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (d:alldat-keys *alldat*))) + (d:alldat-keys data))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-run-keys data) run-id run-path) + (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) - (hash-table-set! (d:data-path-run-ids data) run-path run-id) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") @@ -1360,88 +1378,60 @@ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) - (d:data-runs-tree-set! data tb) + (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;; This is the New View tab ;; -(define (dashboard:new-view db data) +(define (dashboard:new-view db data ddata) (let* ((tb (iup:treebox #:value 0 #:name "Runs" #:expand "YES" #:addexpanded "NO" #:selection-cb (lambda (obj id state) ;; (print "obj: " obj ", id: " id ", state: " state) (let* ((run-path (tree:node->path obj id)) - (run-id (tree-path->run-id data (cdr run-path)))) + (run-id (tree-path->run-id ddata (cdr run-path)))) (if (number? run-id) (begin - (d:data-curr-run-id-set! data run-id) + (d:data-curr-run-id-set! ddata run-id) (dashboard:update-run-summary-tab)) (debug:print 0 "ERROR: tree-path->run-id returned non-number " run-id))) - ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) - ))) + ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) + ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" #:click-cb (lambda (obj lin col status) (let* ((toolpath (car (argv))) (key (conc lin ":" col)) (test-id (hash-table-ref/default cell-lookup key -1)) - (cmd (conc toolpath " -test " (d:data-curr-run-id data) "," test-id "&"))) + (cmd (conc toolpath " -test " (d:data-curr-run-id ddata) "," test-id "&"))) (system cmd))))) (updater (lambda () - (let* ((runs-dat (if (d:alldat-useserver *alldat*) - (rmt:get-runs-by-patt (d:alldat-keys *alldat*) "%" #f #f #f #f) - (db:get-runs-by-patt db (d:alldat-keys *alldat*) "%" #f #f #f #f))) + (let* ((runs-dat (if (d:alldat-useserver data) + (rmt:get-runs-by-patt (d:alldat-keys data) "%" #f #f #f #f) + (db:get-runs-by-patt db (d:alldat-keys data) "%" #f #f #f #f))) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records - (run-id (d:data-curr-run-id data)) + (run-id (d:data-curr-run-id ddata)) (last-update 0) ;; fix me - (tests-dat (let ((tdat (if run-id - (if (d:alldat-useserver *alldat*) - (rmt:get-tests-for-run run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update) ;; get 'em all - (db:get-tests-for-run db run-id - (hash-table-ref/default (d:alldat-searchpatts *alldat*) "test-name" "%/%") - (hash-table-keys (d:alldat-state-ignore-hash *alldat*)) ;; '() - (hash-table-keys (d:alldat-status-ignore-hash *alldat*)) ;; '() - #f #f - (d:alldat-hide-not-hide *alldat*) - #f #f - "id,testname,item_path,state,status" - last-update)) - '()))) ;; get 'em all - (sort tdat (lambda (a b) - (let* ((aval (vector-ref a 2)) - (bval (vector-ref b 2)) - (anum (string->number aval)) - (bnum (string->number bval))) - (if (and anum bnum) - (< anum bnum) - (string<= aval bval))))))) + (tests-dat (dboard:get-tests-dat data run-id last-update)) (tests-mindat (dcommon:minimize-test-data tests-dat)) (indices (common:sparse-list-generate-index tests-mindat)) ;; proc: set-cell)) (row-indices (cadr indices)) (col-indices (car indices)) (max-row (if (null? row-indices) 1 (common:max (map cadr row-indices)))) (max-col (if (null? col-indices) 1 (common:max (map cadr col-indices)))) - (max-visible (max (- (d:alldat-num-tests *alldat*) 15) 3)) ;; (d:alldat-num-tests *alldat*) is proportional to the size of the window + (max-visible (max (- (d:alldat-num-tests data) 15) 3)) ;; (d:alldat-num-tests data) is proportional to the size of the window (numrows 1) (numcols 1) (changed #f) (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) @@ -1460,25 +1450,25 @@ ;; (iup:attribute-set! tb "NAME" "Runs") ;; Update the runs tree (for-each (lambda (run-id) (let* ((run-record (hash-table-ref/default runs-hash run-id #f)) (key-vals (map (lambda (key)(db:get-value-by-header run-record runs-header key)) - (d:alldat-keys *alldat*))) + (d:alldat-keys data))) (run-name (db:get-value-by-header run-record runs-header "runname")) (col-name (conc (string-intersperse key-vals "\n") "\n" run-name)) (run-path (append key-vals (list run-name))) (existing (tree:find-node tb run-path))) - (if (not (hash-table-ref/default (d:data-path-run-ids data) run-path #f)) + (if (not (hash-table-ref/default (d:data-path-run-ids ddata) run-path #f)) (begin - (hash-table-set! (d:data-run-keys data) run-id run-path) + (hash-table-set! (d:data-run-keys ddata) run-id run-path) ;; (iup:attribute-set! (dboard:data-get-runs-matrix *data*) ;; (conc rownum ":" colnum) col-name) ;; (hash-table-set! runid-to-col run-id (list colnum run-record)) ;; Here we update the tests treebox and tree keys (tree:add-node tb "Runs" run-path ;; (append key-vals (list run-name)) userdata: (conc "run-id: " run-id)) - (hash-table-set! (d:data-path-run-ids data) run-path run-id) + (hash-table-set! (d:data-path-run-ids ddata) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids) (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") @@ -1534,11 +1524,11 @@ (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) col-indices) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL")))))) (set! dashboard:update-run-summary-tab updater) - (d:data-runs-tree-set! data tb) + (d:data-runs-tree-set! ddata tb) (iup:split tb run-matrix))) ;;====================================================================== @@ -1590,32 +1580,32 @@ ;; (iup:button "Sort -t" #:action (lambda (obj) ;; (next-sort-option) ;; (iup:attribute-set! obj "TITLE" (vector-ref (vector-ref *tests-sort-options* *tests-sort-reverse*) 0)) ;; (mark-for-update))) (iup:button "HideEmpty" #:action (lambda (obj) - (d:alldat-hide-empty-runs-set! *alldat* (not (d:alldat-hide-empty-runs *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs *alldat*) "+HideE" "-HideE")) + (d:alldat-hide-empty-runs-set! data (not (d:alldat-hide-empty-runs data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-empty-runs data) "+HideE" "-HideE")) (mark-for-update))) (let ((hideit (iup:button "HideTests" #:action (lambda (obj) - (d:alldat-hide-not-hide-set! *alldat* (not (d:alldat-hide-not-hide *alldat*))) - (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide *alldat*) "HideTests" "NotHide")) + (d:alldat-hide-not-hide-set! data (not (d:alldat-hide-not-hide data))) + (iup:attribute-set! obj "TITLE" (if (d:alldat-hide-not-hide data) "HideTests" "NotHide")) (mark-for-update))))) - (d:alldat-hide-not-hide-button-set! *alldat* hideit) ;; never used, can eliminate ... + (d:alldat-hide-not-hide-button-set! data hideit) ;; never used, can eliminate ... hideit)) (iup:hbox (iup:button "Quit" #:action (lambda (obj) - ;; (if (d:alldat-dblocal *alldat*) (db:close-all (d:alldat-dblocal *alldat*))) + ;; (if (d:alldat-dblocal data) (db:close-all (d:alldat-dblocal data))) (exit))) (iup:button "Refresh" #:action (lambda (obj) (mark-for-update))) (iup:button "Collapse" #:action (lambda (obj) (let ((myname (iup:attribute obj "TITLE"))) (if (equal? myname "Collapse") (begin (for-each (lambda (tname) (hash-table-set! *collapsed* tname #t)) - (d:alldat-item-test-names *alldat*)) + (d:alldat-item-test-names data)) (iup:attribute-set! obj "TITLE" "Expand")) (begin (for-each (lambda (tname) (hash-table-delete! *collapsed* tname)) (hash-table-keys *collapsed*)) @@ -1628,38 +1618,38 @@ iup:hbox (map (lambda (status) (iup:toggle status #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! (d:alldat-status-ignore-hash *alldat*) status #t) - (hash-table-delete! (d:alldat-status-ignore-hash *alldat*) status)) + (hash-table-set! (d:alldat-status-ignore-hash data) status #t) + (hash-table-delete! (d:alldat-status-ignore-hash data) status)) (set-bg-on-filter)))) (map cadr *common:std-statuses*))) ;; '("PASS" "FAIL" "WARN" "CHECK" "WAIVED" "STUCK/DEAD" "n/a" "SKIP"))) (apply iup:hbox (map (lambda (state) (iup:toggle state #:action (lambda (obj val) (mark-for-update) (if (eq? val 1) - (hash-table-set! (d:alldat-state-ignore-hash *alldat*) state #t) - (hash-table-delete! (d:alldat-state-ignore-hash *alldat*) state)) + (hash-table-set! (d:alldat-state-ignore-hash data) state #t) + (hash-table-delete! (d:alldat-state-ignore-hash data) state)) (set-bg-on-filter)))) (map cadr *common:std-states*))) ;; '("RUNNING" "COMPLETED" "INCOMPLETE" "LAUNCHED" "NOT_STARTED" "KILLED" "DELETED"))) (iup:valuator #:valuechanged_cb (lambda (obj) (let ((val (inexact->exact (round (/ (string->number (iup:attribute obj "VALUE")) 10)))) (oldmax (string->number (iup:attribute obj "MAX"))) - (maxruns (d:alldat-tot-runs *alldat*))) - (d:alldat-start-run-offset-set! *alldat* val) + (maxruns (d:alldat-tot-runs data))) + (d:alldat-start-run-offset-set! data val) (mark-for-update) - (debug:print 6 "(d:alldat-start-run-offset *alldat*) " (d:alldat-start-run-offset *alldat*) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) + (debug:print 6 "(d:alldat-start-run-offset data) " (d:alldat-start-run-offset data) " maxruns: " maxruns ", val: " val " oldmax: " oldmax) (iup:attribute-set! obj "MAX" (* maxruns 10)))) #:expand "HORIZONTAL" - #:max (* 10 (length (d:alldat-allruns *alldat*))) + #:max (* 10 (length (d:alldat-allruns data))) #:min 0 #:step 0.01))) - ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (+ (d:alldat-num-tests *alldat*) 1)))) - ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! *alldat* (if (> (d:alldat-num-tests *alldat*) 0)(- (d:alldat-num-tests *alldat*) 1) 0)))) + ;(iup:button "inc rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (+ (d:alldat-num-tests data) 1)))) + ;(iup:button "dec rows" #:action (lambda (obj)(d:alldat-num-tests-set! data (if (> (d:alldat-num-tests data) 0)(- (d:alldat-num-tests data) 1) 0)))) ) ) ;; create the left most column for the run key names and the test names (set! lftlst (list (iup:hbox @@ -1683,11 +1673,11 @@ (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 *alltestnamelst*)))) - (d:alldat-please-update-set! *alldat* #t) + (d:alldat-please-update-set! data #t) (d:alldat-start-test-offset-set! *alldat* (inexact->exact (round (/ val 10)))) (debug:print 6 "(d:alldat-start-test-offset *alldat*) " (d:alldat-start-test-offset *alldat*) " val: " val " newmax: " newmax " oldmax: " oldmax) (if (< val 10) (iup:attribute-set! obj "MAX" newmax)) )) @@ -1765,19 +1755,19 @@ (iup:vbox ;; the header (apply iup:hbox (reverse hdrlst)) (apply iup:hbox (reverse bdylst)))))) controls)) - (data (d:data-init (make-d:data))) + ;; (data (d:data-init (make-d:data))) (tabs (iup:tabs #:tabchangepos-cb (lambda (obj curr prev) (d:alldat-please-update-set! *alldat* #t) (d:alldat-curr-tab-num-set! *alldat* curr)) (dashboard:summary *alldat*) runs-view - (dashboard:one-run db runs-sum-dat) - (dashboard:new-view db new-view-dat) + (dashboard:one-run db data runs-sum-dat) + (dashboard:new-view db data new-view-dat) (dashboard:run-controls) ))) ;; (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") @@ -1886,20 +1876,21 @@ (let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc"))) (if (file-exists? debugcontrolf) (load debugcontrolf))) (define (main) - (let ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab - (new-view-dat (d:data-init (make-d:data)))) + (let* ((runs-sum-dat (d:data-init (make-d:data))) ;; data for run-summary tab + (new-view-dat runs-sum-dat) ;; NOT YET SEPARATE (d:data-init (make-d:data)))) + (data *alldat*)) (cond ((args:get-arg "-run") (let ((runid (string->number (args:get-arg "-run")))) (if runid (begin (lambda (x) (on-exit std-exit-procedure) - (examine-run (d:alldat-dblocal *alldat*) runid))) + (examine-run (d:alldat-dblocal data) runid))) (begin (print "ERROR: runid is not a number " (args:get-arg "-run")) (exit 1))))) ((args:get-arg "-test") ;; run-id,test-id (let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ",")))) @@ -1914,39 +1905,39 @@ (examine-test run-id test-id) (begin (debug:print 3 "INFO: tried to open test with invalid run-id,test-id. " (args:get-arg "-test")) (exit 1))))) ((args:get-arg "-guimonitor") - (gui-monitor (d:alldat-dblocal *alldat*))) + (gui-monitor (d:alldat-dblocal data))) (else - (set! uidat (make-dashboard-buttons *alldat* ;; (d:alldat-dblocal *alldat*) - (d:alldat-numruns *alldat*) - (d:alldat-num-tests *alldat*) - (d:alldat-dbkeys *alldat*) - runs-sum-dat new-view-dat)) + (set! uidat (make-dashboard-buttons data ;; (d:alldat-dblocal data) + (d:alldat-numruns data) + (d:alldat-num-tests data) + (d:alldat-dbkeys data) + runs-sum-dat new-view-dat)) (iup:callback-set! *tim* "ACTION_CB" (lambda (x) (let ((update-is-running #f)) - (mutex-lock! (d:alldat-update-mutex *alldat*)) - (set! update-is-running (d:alldat-updating *alldat*)) + (mutex-lock! (d:alldat-update-mutex data)) + (set! update-is-running (d:alldat-updating data)) (if (not update-is-running) - (d:alldat-updating-set! *alldat* #t)) - (mutex-unlock! (d:alldat-update-mutex *alldat*)) + (d:alldat-updating-set! data #t)) + (mutex-unlock! (d:alldat-update-mutex data)) (if (not update-is-running) (begin (dashboard:run-update x) - (mutex-lock! (d:alldat-update-mutex *alldat*)) - (d:alldat-updating-set! *alldat* #f) - (mutex-unlock! (d:alldat-update-mutex *alldat*))))) + (mutex-lock! (d:alldat-update-mutex data)) + (d:alldat-updating-set! data #f) + (mutex-unlock! (d:alldat-update-mutex data))))) 1)))) (let ((th1 (make-thread (lambda () (thread-sleep! 1) - (d:alldat-please-update-set! *alldat* #t) + (d:alldat-please-update-set! data #t) (dashboard:run-update 1)) "update buttons once")) (th2 (make-thread iup:main-loop "Main loop"))) (thread-start! th1) (thread-start! th2) (thread-join! th2)))) (main)