Index: common.scm ================================================================== --- common.scm +++ common.scm @@ -998,11 +998,11 @@ ;; given span of seconds tstart to tend ;; find start time to mark and mark delta ;; (define (common:find-start-mark-and-mark-delta tstart tend) - (let* ((deltat (- tend tstart)) + (let* ((deltat (- (max tend (+ tend 10)) tstart)) ;; can't handle runs of less than 4 seconds. Pad it to 10 seconds ... (result #f) (min 60) (hr (* 60 60)) (day (* 24 hr)) (yr (* 365 day)) ;; year Index: dashboard.scm ================================================================== --- dashboard.scm +++ dashboard.scm @@ -172,10 +172,13 @@ (keys #f) ;; keys for this run (i.e. target components) ((numruns (string->number (or (args:get-arg "-cols") "8"))) : number) ;; ((tot-runs 0) : number) ((last-data-update 0) : number) ;; last time the data in allruns was updated (runs-mutex (make-mutex)) ;; use to prevent parallel access to draw objects + ((run-update-times (make-hash-table)) : hash-table) ;; update times indexed by run-id + (last-test-dat #f) ;; cache last tests dat + ((run-db-paths (make-hash-table)) : hash-table) ;; cache the paths to the run db files ;; Runs view ((buttondat (make-hash-table)) : hash-table) ;; ((item-test-names '()) : list) ;; list of itemized tests ((run-keys (make-hash-table)) : hash-table) @@ -302,10 +305,11 @@ tests ;; hash of id => testdat tests-by-name ;; hash of testfullname => testdat key-vals ((last-update 0) : fixnum) ;; last query to db got records from before last-update data-changed + (db-path #f) ) (define (dboard:rundat-make-init #!key (run #f)(key-vals #f)(tests #f)(last-update -100));; -100 is before time began (make-dboard:rundat run: run @@ -487,20 +491,28 @@ (let ((rd (dboard:rundat-make-init run: run key-vals: key-vals))) (hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id rd) rd)))) ;; (prev-tests (dboard:rundat-tests prev-dat)) ;; (vector-ref prev-dat 1)) (last-update (dboard:rundat-last-update run-dat)) ;; (vector-ref prev-dat 3)) - (tmptests (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses - #f #f ;; offset limit - (dboard:tabdat-hide-not-hide tabdat) ;; no-in - sort-by ;; sort-by - sort-order ;; sort-order - #f ;; 'shortlist ;; qrytype - (if (dboard:tabdat-filters-changed tabdat) - 0 - last-update) ;; last-update - *dashboard-mode*)) ;; use dashboard mode + (db-path (or (dboard:rundat-db-path run-dat) + (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 (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") + (>= (file-modification-time db-path) last-update)) + (rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses + #f #f ;; offset limit + (dboard:tabdat-hide-not-hide tabdat) ;; no-in + sort-by ;; sort-by + sort-order ;; sort-order + #f ;; 'shortlist ;; qrytype + (if (dboard:tabdat-filters-changed tabdat) + 0 + last-update) ;; last-update + *dashboard-mode*) ;; use dashboard mode + '())) (use-new (dboard:tabdat-hide-not-hide tabdat)) (tests-ht (if (dboard:tabdat-filters-changed tabdat) (let ((ht (make-hash-table))) (dboard:rundat-tests-set! run-dat ht) ht) @@ -1259,11 +1271,11 @@ (let ((drawing (dboard:tabdat-drawing tabdat)) (old-xadj (dboard:tabdat-xadj tabdat)) (old-yadj (dboard:tabdat-yadj tabdat))) (if (not (and (eq? xadj old-xadj)(eq? yadj old-yadj))) (begin - (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) + ;; (print "xadj: " xadj " yadj: " yadj "changed: "(eq? xadj old-xadj) " " (eq? yadj old-yadj)) (dboard:tabdat-view-changed-set! tabdat #t) (dboard:tabdat-xadj-set! tabdat (* -2000 (- xadj 0.5))) (dboard:tabdat-yadj-set! tabdat (* 2000 (- yadj 0.5))) )))) "iup:canvas action"))) @@ -1293,11 +1305,11 @@ (if (not (null? path)) (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) path #f) #f)) (define (dboard:get-tests-dat tabdat run-id last-update) - (let ((tdat (if run-id (rmt:get-tests-for-run run-id + (let* ((tdat (if run-id (rmt:get-tests-for-run run-id (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%") (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)) ;; '() (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)) ;; '() #f #f ;; offset limit (dboard:tabdat-hide-not-hide tabdat) ;; not-in @@ -1359,12 +1371,21 @@ (define (dashboard:one-run-updater commondat tabdat tb cell-lookup run-matrix) (let* ((runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f)) (runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records (run-id (dboard:tabdat-curr-run-id tabdat)) - (last-update 0) ;; fix me - have to create and store a rundat record for this - (tests-dat (dboard:get-tests-dat tabdat run-id last-update)) + (last-update (hash-table-ref/default (dboard:tabdat-run-update-times tabdat) run-id 0)) + (db-path (or (hash-table-ref/default (dboard:tabdat-run-db-paths tabdat) run-id #f) + (let* ((db-dir (tasks:get-task-db-path)) + (db-pth (conc db-dir "/" run-id ".db"))) + (hash-table-set! (dboard:tabdat-run-db-paths tabdat) run-id db-pth) + db-pth))) + (tests-dat (if (or (not run-id) + (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps") + (>= (file-modification-time db-path) last-update)) + (dboard:get-tests-dat tabdat run-id last-update) + (dboard:tabdat-last-test-dat tabdat))) (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)))) @@ -1376,80 +1397,82 @@ (runs-hash (let ((ht (make-hash-table))) (for-each (lambda (run) (hash-table-set! ht (db:get-value-by-header run runs-header "id") run)) (vector-ref runs-dat 1)) ht))) + (dboard:tabdat-last-test-dat-set! tabdat tests-dat) + (hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10)) (dboard:tabdat-filters-changed-set! tabdat #f) (let loop ((pass-num 0) (changed #f)) ;; Update the runs tree (dboard:update-tree tabdat runs-hash runs-header tb) - -(if (eq? pass-num 1) + + (if (eq? pass-num 1) (begin ;; big reset - (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS - (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") - (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") - (iup:attribute-set! run-matrix "NUMCOL" max-col ) - (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 - - ;; Row labels - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc num ":0"))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name))))) - row-indices) - - (print "row-indices: " row-indices " col-indices: " col-indices) + (iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS + (iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS") + (iup:attribute-set! run-matrix "RESIZEMATRIX" "YES") + (iup:attribute-set! run-matrix "NUMCOL" max-col ) + (iup:attribute-set! run-matrix "NUMLIN" (if (< max-row max-visible) max-visible max-row)))) ;; min of 20 + + ;; Row labels + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc num ":0"))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name))))) + row-indices) + + ;; (print "row-indices: " row-indices " col-indices: " col-indices) (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass - - ;; Cell contents - (for-each (lambda (entry) - ;; (print "entry: " entry) - (let* ((row-name (cadr entry)) - (col-name (car entry)) - (valuedat (caddr entry)) - (test-id (list-ref valuedat 0)) - (test-name row-name) ;; (list-ref valuedat 1)) - (item-path col-name) ;; (list-ref valuedat 2)) - (state (list-ref valuedat 1)) - (status (list-ref valuedat 2)) - (value (gutils:get-color-for-state-status state status)) - (row-num (cadr (assoc row-name row-indices))) - (col-num (cadr (assoc col-name col-indices))) - (key (conc row-num ":" col-num))) - (hash-table-set! cell-lookup key test-id) - (if (not (equal? (iup:attribute run-matrix key) (cadr value))) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key (cadr value)) - (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) - tests-mindat) - - ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. - - (for-each (lambda (ind) - (let* ((name (car ind)) - (num (cadr ind)) - (key (conc "0:" num))) - (if (not (equal? (iup:attribute run-matrix key) name)) - (begin - (set! changed #t) - (iup:attribute-set! run-matrix key name) - (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) - col-indices) - + + ;; Cell contents + (for-each (lambda (entry) + ;; (print "entry: " entry) + (let* ((row-name (cadr entry)) + (col-name (car entry)) + (valuedat (caddr entry)) + (test-id (list-ref valuedat 0)) + (test-name row-name) ;; (list-ref valuedat 1)) + (item-path col-name) ;; (list-ref valuedat 2)) + (state (list-ref valuedat 1)) + (status (list-ref valuedat 2)) + (value (gutils:get-color-for-state-status state status)) + (row-num (cadr (assoc row-name row-indices))) + (col-num (cadr (assoc col-name col-indices))) + (key (conc row-num ":" col-num))) + (hash-table-set! cell-lookup key test-id) + (if (not (equal? (iup:attribute run-matrix key) (cadr value))) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key (cadr value)) + (iup:attribute-set! run-matrix (conc "BGCOLOR" key) (car value)))))) + tests-mindat) + + ;; Col labels - do after setting Cell contents so they are accounted for in the size calc. + + (for-each (lambda (ind) + (let* ((name (car ind)) + (num (cadr ind)) + (key (conc "0:" num))) + (if (not (equal? (iup:attribute run-matrix key) name)) + (begin + (set! changed #t) + (iup:attribute-set! run-matrix key name) + (iup:attribute-set! run-matrix "FITTOTEXT" (conc "C" num)))))) + col-indices) + (if (and (eq? pass-num 0) changed) (loop 1 #t)) ;; force second pass due to column labels changing - + ;; (debug:print 0 *default-debug-port* "one-run-updater, changed: " changed " pass-num: " pass-num) - (print "one-run-updater, changed: " changed " pass-num: " pass-num) + ;; (print "one-run-updater, changed: " changed " pass-num: " pass-num) (if changed (iup:attribute-set! run-matrix "REDRAW" "ALL"))))) ;;====================================================================== ;; S U M M A R Y ;;====================================================================== @@ -1513,11 +1536,12 @@ (begin (dboard:tabdat-curr-run-id-set! tabdat run-id) (dboard:tabdat-layout-update-ok-set! tabdat #f) ;; (dashboard:update-run-summary-tab) ) - (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id))) + ;; (debug:print-error 0 *default-log-port* "tree-path->run-id returned non-number " run-id) + )) ;; (print "path: " (tree:node->path obj id) " run-id: " run-id) ))) (cell-lookup (make-hash-table)) (run-matrix (iup:matrix #:expand "YES" @@ -2375,11 +2399,11 @@ userdata: (conc "run-id: " run-id)) (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id) ;; (set! colnum (+ colnum 1)) )))) run-ids)) - (print "Updating rundat") + ;; (print "Updating rundat") (if (dboard:tabdat-keys tabdat) ;; have keys yet? (let* ((num-keys (length (dboard:tabdat-keys tabdat))) (targpatt (map (lambda (k v) (list k v)) (dboard:tabdat-keys tabdat) @@ -2391,11 +2415,11 @@ (runpatt (if (dboard:tabdat-target tabdat) (last (dboard:tabdat-target tabdat)) "%")) (testpatt (or (dboard:tabdat-test-patts tabdat) "%")) (filtrstr (conc targpatt "/" runpatt "/" testpatt))) - (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) + ;; (print "targpatt: " targpatt " runpatt: " runpatt " testpatt: " testpatt) (if (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr)) (let ((dwg (dboard:tabdat-drawing tabdat))) (print "reseting drawing") (dboard:tabdat-layout-update-ok-set! tabdat #f) @@ -2481,11 +2505,10 @@ (begin (for-each (lambda (fieldname) ;; fields (let ((all-dat-qrystr (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " >= " tstart " AND " timef " <= " tend " ORDER BY " timef " ASC")) (zeroth-point (conc "SELECT " timef "," varfn "," valfn " FROM " tablen " WHERE " varfn "='" fieldname "' AND " timef " < " tstart " LIMIT 1"))) - (print "all-dat-qrystr: " all-dat-qrystr) (hash-table-set! res-ht fieldname ;; (fetch-rows (sql db qrystr))))) (reverse (sqlite3:fold-row (lambda (res t var val) (cons (vector t var val) res)) @@ -2668,11 +2691,12 @@ (testsdat (hash-table-values tests-ht)) (runcomp (vg:comp-new));; new component for this run (rows-used (make-hash-table)) ;; keep track of what parts of the rows are used here row1 = (obj1 obj2 ...) ;; (row-height 4) (run-start (dboard:min-max < (map db:test-get-event_time testsdat))) - (run-end (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat))) + (run-end (let ((re (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))) + (max re (+ 1 run-start)))) ;; use run-start+1 if run-start == run-end so delta is not zero (timeoffset (- run-start)) ;; (+ fixed-originx canvas-margin) run-start)) (run-duration (- run-end run-start)) (timescale (/ (- sizex (* 2 canvas-margin)) (if (> run-duration 0) run-duration @@ -2683,11 +2707,11 @@ (width (* timescale run-duration)) (graph-lly (calc-y (/ -50 row-height))) (graph-uly (- (calc-y 0) canvas-margin)) (sec-per-50pt (/ 50 timescale)) ) - (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) + ;; (print "timeoffset: " timeoffset " timescale: " timescale " run-duration: " (seconds->hr-min-sec run-duration) " width: " width " sec-per-50pt: " sec-per-50pt) ;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx) (mutex-lock! mtx) (vg:add-comp-to-lib runslib run-full-name runcomp) ;; Have to keep moving the instantiated box as it is anchored at the lower left ;; this should have worked for x in next statement? (maptime run-start) Index: dcommon.scm ================================================================== --- dcommon.scm +++ dcommon.scm @@ -275,11 +275,11 @@ (tal (cdr tests-dat)) (res '())) (let* ((test-id (db:test-get-id hed)) ;; look at the tests-dat spec for locations (test-name (db:test-get-testname hed)) (item-path (db:test-get-item-path hed)) - (state (db:test-get-status hed)) + (state (db:test-get-state hed)) (status (db:test-get-status hed)) (newitem (list test-name item-path (list test-id state status)))) (if (null? tal) (reverse (cons newitem res)) (loop (car tal)(cdr tal)(cons newitem res))))))) Index: docs/manual/megatest_manual.html ================================================================== --- docs/manual/megatest_manual.html +++ docs/manual/megatest_manual.html @@ -1,10 +1,10 @@
- +