︙ | | | ︙ | |
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
|
(lambda ()
(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
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#: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
|
<
>
|
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
|
(lambda ()
(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"
))
(tb
(iup:treebox
#:value 0
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#: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
|
︙ | | | ︙ | |
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
|
(dboard:graph-dat-flag-set! graph-dat #t)))
(hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))
(iup:hbox
(iup:button "Hide All" #:action (lambda (obj)
(for-each (lambda (graph-cell)
(let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
(dboard:graph-dat-flag-set! graph-dat #f)))
(hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))))))
))))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
|
|
>
|
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
|
(dboard:graph-dat-flag-set! graph-dat #t)))
(hash-table-keys (dboard:tabdat-graph-cell-table tabdat))))))
(iup:hbox
(iup:button "Hide All" #:action (lambda (obj)
(for-each (lambda (graph-cell)
(let* ((graph-dat (hash-table-ref (dboard:tabdat-graph-cell-table tabdat) graph-cell)))
(dboard:graph-dat-flag-set! graph-dat #f)))
(hash-table-keys (dboard:tabdat-graph-cell-table tabdat)))
(dboard:tabdat-view-changed-set! tabdat #t)))))
))))
;;======================================================================
;; R U N
;;======================================================================
;;
;; display and manage a single run at a time
|
︙ | | | ︙ | |
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
|
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 150
(dboard:runs-tree-browser commondat runs-dat)
(iup:split
;; left most block, including row names
(apply iup:vbox lftlst)
;; right hand block, including cells
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst)))))
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
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
|
|
|
|
|
|
|
|
|
|
|
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
|
(iup:show
(iup:dialog
#:title (conc "Megatest dashboard " (current-user-name) ":" *toppath*)
#:menu (dcommon:main-menu)
(let* ((runs-view (iup:vbox
(iup:split
#:orientation "VERTICAL" ;; "HORIZONTAL"
#:value 200
(dboard:runs-tree-browser commondat runs-dat)
(iup:split
;; left most block, including row names
(apply iup:vbox lftlst)
;; right hand block, including cells
(iup:vbox
;; the header
(apply iup:hbox (reverse hdrlst))
(apply iup:hbox (reverse bdylst)))))
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
;; (data (dboard:tabdat-init (make-d:data)))
(additional-views ;; process views-dat
|
︙ | | | ︙ | |
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
|
(define (dashboard:get-youngest-run-db-mod-time tabdat)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(apply max (map (lambda (filen)
(file-modification-time filen))
(glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
|
|
|
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
|
(define (dashboard:get-youngest-run-db-mod-time tabdat)
(handle-exceptions
exn
(begin
(debug:print 0 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: " ((condition-property-accessor 'exn 'message) exn))
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
(file-modification-time filen))
(glob (conc (dboard:tabdat-dbdir tabdat) "/*.db"))))))
(define (dashboard:monitor-changed? commondat tabdat)
(let* ((run-update-time (current-seconds))
(monitor-db-path (dboard:tabdat-monitor-db-path tabdat))
(monitor-modtime (if (and monitor-db-path (file-exists? monitor-db-path))
|
︙ | | | ︙ | |
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
|
(hash-table-set! rowhash
(+ i rownum)
(cons (cons x1 x2)
(hash-table-ref/default rowhash (+ i rownum) '())))
(if (< i num-rows)
(loop (+ i 1)))))
;; get min or max, use > for max and < for min, this works around the limits on apply
;;
(define (dboard:min-max comp lst)
(if (null? lst)
#f ;; better than an exception for my needs
(fold (lambda (a b)
(if (comp a b) a b))
(car lst)
lst)))
;; sort a list of test-ids by the event _time using a hash table of id => testdat
;;
(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht)
(sort test-ids
(lambda (a b)
(< (db:test-get-event_time (hash-table-ref tests-ht a))
(db:test-get-event_time (hash-table-ref tests-ht b))))))
|
<
<
<
<
<
<
<
<
<
<
|
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
|
(hash-table-set! rowhash
(+ i rownum)
(cons (cons x1 x2)
(hash-table-ref/default rowhash (+ i rownum) '())))
(if (< i num-rows)
(loop (+ i 1)))))
;; sort a list of test-ids by the event _time using a hash table of id => testdat
;;
(define-inline (dboard:sort-testsdat-by-event-time test-ids tests-ht)
(sort test-ids
(lambda (a b)
(< (db:test-get-event_time (hash-table-ref tests-ht a))
(db:test-get-event_time (hash-table-ref tests-ht b))))))
|
︙ | | | ︙ | |
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
|
(list? (dboard:tabdat-target tabdat))
(not (null? (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)
(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)
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
|
>
|
>
|
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
|
(list? (dboard:tabdat-target tabdat))
(not (null? (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 "RA => dboard:tabdat-last-filter-str " dboard:tabdat-last-filter-str "filtrstr" filtrstr "dboard:tabdat-view-changed" (dboard:tabdat-view-changed tabdat))
(if (or (not (equal? (dboard:tabdat-last-filter-str tabdat) filtrstr))
(dboard:tabdat-view-changed tabdat))
(let ((dwg (dboard:tabdat-drawing tabdat)))
(print "reseting drawing")
(dboard:tabdat-layout-update-ok-set! tabdat #f)
(vg:drawing-libs-set! dwg (make-hash-table))
(vg:drawing-insts-set! dwg (make-hash-table))
(vg:drawing-cache-set! dwg '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
|
︙ | | | ︙ | |
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
|
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
(mutex-unlock! mtx)
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; doesn't work.
;;
;;(define (gotoescape tabdat escape)
;; (or (dboard:tabdat-layout-update-ok tabdat)
;; (escape #t)))
|
>
>
|
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
|
(if (and cnv dwg vch)
(begin
(vg:drawing-xoff-set! dwg (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! dwg (dboard:tabdat-yadj tabdat))
(mutex-lock! mtx)
(canvas-clear! cnv)
(vg:draw dwg tabdat)
;; RA => (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(mutex-unlock! mtx)
(print "RA => View changed found to be set" )
(dboard:tabdat-view-changed-set! tabdat #f)))))
;; doesn't work.
;;
;;(define (gotoescape tabdat escape)
;; (or (dboard:tabdat-layout-update-ok tabdat)
;; (escape #t)))
|
︙ | | | ︙ | |
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
|
(dboard:rundat-hierdat rundat)))
(tests-ht (dboard:rundat-tests rundat))
(all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
(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 (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
(current-seconds)))) ;; a least lously guess
|
|
|
|
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
|
(dboard:rundat-hierdat rundat)))
(tests-ht (dboard:rundat-tests rundat))
(all-tids (hash-table-keys tests-ht)) ;; (apply append hierdat)) ;; was testsdat
(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 (common:min-max < (map db:test-get-event_time testsdat)))
(run-end (let ((re (common: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
(current-seconds)))) ;; a least lously guess
|
︙ | | | ︙ | |