| ︙ | | | ︙ | |
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
|
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbmod))
(declare (uses rmtmod))
(declare (uses dbfile))
(declare (uses commonmod))
(declare (uses commonmod.import))
(use format)
(require-library iup)
(import (prefix iup iup:))
|
>
>
|
|
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
|
(declare (uses tree))
(declare (uses dcommon))
(declare (uses dashboard-context-menu))
(declare (uses vg))
(declare (uses subrun))
(declare (uses mt))
(declare (uses dbmod))
(declare (uses dbfile))
(declare (uses dbfile.import))
(declare (uses rmtmod))
(declare (uses rmtmod.import))
(declare (uses commonmod))
(declare (uses commonmod.import))
(use format)
(require-library iup)
(import (prefix iup iup:))
|
| ︙ | | | ︙ | |
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")
(dbfile:db-init-proc db:initialize-main-db)
(set! rmtmod:send-receive rmt:send-receive)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
" license GPL, Copyright (C) Matt Welland 2012-2017
Usage: dashboard [options]
-h : this help
|
>
>
|
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
;; set some parameters here - these need to be put in something that can be loaded from other
;; executables such as dashboard and mtutil
;;
(include "dashboard-transport-mode.scm")
(dbfile:db-init-proc db:initialize-main-db)
(set! rmtmod:send-receive rmt:send-receive)
(debug:print-info 0 *default-log-port* "transport-mode="(rmt:transport-mode))
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest version " megatest-version
" license GPL, Copyright (C) Matt Welland 2012-2017
Usage: dashboard [options]
-h : this help
|
| ︙ | | | ︙ | |
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
|
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
(if (args:get-arg "-mode")
(let* ((mode (string->symbol (args:get-arg "-mode"))))
(rmt:transport-mode mode))
(rmt:transport-mode 'tcp))
(if (args:get-arg "-test") ;; need to use tcp for test control panel
(rmt:transport-mode 'tcp))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
|
|
|
|
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
(if (args:get-arg "-mode")
(let* ((mode (string->symbol (args:get-arg "-mode"))))
(rmt:transport-mode mode)))
;; (rmt:transport-mode 'tcp))
(if (args:get-arg "-test") ;; need to use tcp for test control panel
(rmt:transport-mode 'tcp))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
|
| ︙ | | | ︙ | |
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
|
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
|
|
|
|
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
|
(define (dboard:tabdat-make-data)
(let ((dat (make-dboard:tabdat)))
(dboard:setup-tabdat dat)
(dboard:setup-num-rows dat)
dat))
(define (dboard:setup-tabdat tabdat)
(dboard:tabdat-dbdir-set! tabdat (common:make-tmpdir-name *toppath* "")) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (common:make-tmpdir-name *toppath* ""))
(dboard:tabdat-monitor-db-path-set! tabdat (conc (dboard:tabdat-dbdir tabdat) "/monitor.db"))
;; HACK ALERT: this is a hack, please fix.
(dboard:tabdat-ro-set! tabdat (not (file-read-access? (dboard:tabdat-dbfpath tabdat))))
(dboard:tabdat-keys-set! tabdat (rmt:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
|
| ︙ | | | ︙ | |
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
|
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((start-time (current-seconds))
(access-mode (dboard:tabdat-access-mode tabdat))
(num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
"200")))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
(do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
|
|
|
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
|
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((start-time (current-seconds))
(access-mode (dboard:tabdat-access-mode tabdat))
(num-to-get (string->number (or (configf:lookup *configdat* "setup" "num-tests-to-get")
"1000")))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
(statuses (hash-table-keys (dboard:tabdat-status-ignore-hash tabdat)))
(do-not-use-db-file-timestamps #f) ;; (configf:lookup *configdat* "setup" "do-not-use-db-file-timestamps")) ;; this still hosts runs-summary-tab
(do-not-use-query-timestamps #t) ;; (configf:lookup *configdat* "setup" "do-not-use-query-timestamps")) ;; this no longer troubles runs-summary-tab
(sort-info (get-curr-sort))
(sort-by (vector-ref sort-info 1))
(sort-order (vector-ref sort-info 2))
|
| ︙ | | | ︙ | |
851
852
853
854
855
856
857
858
859
860
861
862
863
864
|
maxtests)
(if (> (dboard:rundat-run-data-offset run-struct) 0)
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
|
>
>
>
>
>
>
|
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
|
maxtests)
(if (> (dboard:rundat-run-data-offset run-struct) 0)
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
(define *dashboard-last-run-id-update* (make-hash-table)) ;; id => seconds
(define (dboard:clear-run-id-update-hash)
(hash-table-clear! *dashboard-last-run-id-update*))
;; this calls dboard:get-tests-for-run-duplicate for each run
;;
;; create a virtual table of all the tests
;; keypatts: ( (KEY1 "abc%def")(KEY2 "%") )
;;
(define (dboard:update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
|
| ︙ | | | ︙ | |
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
|
(dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-all-test-names-set! tabdat '())
(dboard:tabdat-item-test-names-set! tabdat '())
(hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0))
(let* ((run-id (db:get-value-by-header run header "id"))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (rmt:get-key-vals run-id))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids)))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
;; (tests (bubble-up tmptests priority: bubble-type))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(let* ((newmaxtests (max num-tests maxtests))
;; (last-update (- (current-seconds) 10))
(run-struct (or run-struct
(dboard:rundat-make-init
run: run
tests: tests-ht
key-vals: key-vals)))
(new-res (if (null? all-test-ids)
res
(delete-duplicates
(cons run-struct res)
(lambda (a b)
(eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
(db:get-value-by-header (dboard:rundat-run b) header "id"))))))
(elapsed-time (- (current-seconds) start-time)))
(if (null? all-test-ids)
(hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
(if (or (null? tal)
(> elapsed-time 2)) ;; stop loading data after 5 seconds, on the next call more data *should* be loaded since get-tests-for-run uses last update
(begin
(when (> elapsed-time 2)
(debug:print 0 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
(let* ((old-val (iup:attribute *tim* "TIME"))
(new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
(if (< (string->number new-val) 5000)
(begin
(debug:print 0 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
(iup:attribute-set! *tim* "TIME" new-val)))))
(dboard:tabdat-allruns-set! tabdat new-res)
maxtests)
(if (> (dboard:rundat-run-data-offset run-struct) 0)
(loop run tal new-res newmaxtests) ;; not done getting data for this run
(loop (car tal)(cdr tal) new-res newmaxtests)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
|
|
>
>
>
>
>
>
|
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
>
>
|
|
|
|
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
|
(dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-all-test-names-set! tabdat '())
(dboard:tabdat-item-test-names-set! tabdat '())
(hash-table-clear! (dboard:tabdat-allruns-by-id tabdat)))
(let loop ((run (car runs))
(tal (cdr runs))
(res '())
(maxtests 0)
(cont-run #f))
(let* ((run-id (db:get-value-by-header run header "id"))
(recently-done (< (- (current-seconds)
(hash-table-ref/default *dashboard-last-run-id-update* run-id 0)) 3))
(run-struct (hash-table-ref/default (dboard:tabdat-allruns-by-id tabdat) run-id #f))
;; (last-update (if run-struct (dboard:rundat-last-update run-struct) 0))
(key-vals (rmt:get-key-vals run-id))
(tests-ht (let* ((tht (if (and recently-done run-struct)
(let ((rht (dboard:rundat-tests run-struct))) ;; (dboard:tabdat-allruns-by-id tabdat)))
(or rht
(dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)))
(dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))))
(assert (hash-table? tht) "FATAL: But here tht should be a hash-table")
tht))
;; GET RID OF dboard:get-tests-dat - it is superceded by dboard:get-tests-for-run-duplicate
;; dboard:get-tests-for-run-duplicate - returns a hash table
;; (dboard:get-tests-dat tabdat run-id last-update))
(all-test-ids (hash-table-keys tests-ht))
(num-tests (length all-test-ids))
;; (print "run-struct: " run-struct)
;; NOTE: bubble-up also sets the global (dboard:tabdat-item-test-names tabdat)
;; (tests (bubble-up tmptests priority: bubble-type))
;; NOTE: 11/01/2013 This routine is *NOT* getting called excessively.
;; (debug:print 0 *default-log-port* "Getting data for run " run-id " with key-vals=" key-vals)
;; Not sure this is needed?
(newmaxtests (max num-tests maxtests))
;; (last-update (- (current-seconds) 10))
(run-struct (or run-struct
(dboard:rundat-make-init
run: run
tests: tests-ht
key-vals: key-vals)))
(new-res (if (null? all-test-ids)
res
(delete-duplicates
(cons run-struct res)
(lambda (a b)
(eq? (db:get-value-by-header (dboard:rundat-run a) header "id")
(db:get-value-by-header (dboard:rundat-run b) header "id"))))))
(elapsed-time (- (current-seconds) start-time)))
(if (null? all-test-ids)
(hash-table-delete! (dboard:tabdat-allruns-by-id tabdat) run-id)
(hash-table-set! (dboard:tabdat-allruns-by-id tabdat) run-id run-struct))
(if (or (null? tal)
(> elapsed-time 2)) ;; stop loading data after 5
;; seconds, on the next call
;; more data *should* be
;; loaded since
;; get-tests-for-run uses last
;; update
(begin
(when (> elapsed-time 2)
(debug:print 2 *default-log-port* "NOTE: updates are taking a long time, " elapsed-time "s elapsed.")
(let* ((old-val (iup:attribute *tim* "TIME"))
(new-val (number->string (inexact->exact (floor (* 2 (string->number old-val)))))))
(if (< (string->number new-val) 5000)
(begin
(debug:print 2 *default-log-port* "NOTE: increasing poll interval from "old-val" to "new-val)
(iup:attribute-set! *tim* "TIME" new-val)))))
(dboard:tabdat-allruns-set! tabdat new-res)
maxtests)
(if (> (dboard:rundat-run-data-offset run-struct) 0)
(begin
(thread-sleep! 0.2) ;; let the gui re-draw
(loop run tal new-res newmaxtests #t)) ;; not done getting data for this run
(begin
(hash-table-set! *dashboard-last-run-id-update* run-id (current-seconds))
(loop (car tal)(cdr tal) new-res newmaxtests #f)))))))
(dboard:tabdat-filters-changed-set! tabdat #f)
(dboard:update-tree tabdat runs-hash header tb)))
(define *collapsed* (make-hash-table))
(define (toggle-hide lnum uidat) ; fulltestname)
(let* ((btn (vector-ref (dboard:uidat-get-lftcol uidat) lnum))
(fulltestname (iup:attribute btn "TITLE"))
(parts (string-split fulltestname "("))
|
| ︙ | | | ︙ | |
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
|
#:modal? "NO")
)
)
)) "runs-summary-click-callback"))))
(runs-summary-updater
(lambda ()
(mutex-lock! update-mutex)
(if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater)
(dboard:tabdat-view-changed tabdat))
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
"dashboard:runs-summary-updater")
)
(mutex-unlock! update-mutex)))
(runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
)
(dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
|
|
|
>
|
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
|
#:modal? "NO")
)
)
)) "runs-summary-click-callback"))))
(runs-summary-updater
(lambda ()
;; (mutex-lock! update-mutex)
(if (or (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-updater)
(dboard:tabdat-view-changed tabdat))
(debug:catch-and-dump
(lambda () ;; check that run-matrix is initialized before calling the updater
(if run-matrix
(dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)))
"dashboard:runs-summary-updater")
)
#;(mutex-unlock! update-mutex)
))
(runs-summary-control-panel (dashboard:runs-summary-control-panel tabdat))
)
(dboard:commondat-add-updater commondat runs-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
|
| ︙ | | | ︙ | |
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
|
(iup:vbox
(iup:hbox
(iup:vbox
(iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
#:expand "NO"
#:action (lambda (obj unk val)
(debug:catch-and-dump
(lambda ()
(mark-for-update tabdat)
(update-search commondat tabdat "test-name" val))
"make-controls")))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
(exit))
#:expand "NO" #:size "40x15")
(iup:button "Refresh" #:action (lambda (obj)
(dboard:tabdat-last-data-update-set! tabdat 0)
(dboard:tabdat-last-runs-update-set! tabdat 0)
(dboard:tabdat-run-update-times-set! tabdat (make-hash-table))
(dboard:tabdat-last-test-dat-set! tabdat (make-hash-table))
(dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
(dboard:tabdat-done-runs-set! tabdat '())
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-view-changed-set! tabdat #t)
(dboard:commondat-please-update-set! commondat #t)
(mark-for-update tabdat))
#:expand "NO" #:size "40x15")
(iup:button "Collapse" #:action (lambda (obj)
(debug:catch-and-dump
(lambda ()
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
|
|
>
|
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
|
(iup:vbox
(iup:hbox
(iup:vbox
(iup:textbox #:size "120x15" #:fontsize "10" #:value "%"
#:expand "NO"
#:action (lambda (obj unk val)
(debug:catch-and-dump
(lambda ()57
(mark-for-update tabdat)
(update-search commondat tabdat "test-name" val))
"make-controls")))
(iup:hbox
(iup:button "Quit" #:action (lambda (obj)
(exit))
#:expand "NO" #:size "40x15")
(iup:button "Refresh" #:action (lambda (obj)
(dboard:tabdat-last-data-update-set! tabdat 0)
(dboard:tabdat-last-runs-update-set! tabdat 0)
(dboard:tabdat-run-update-times-set! tabdat (make-hash-table))
(dboard:tabdat-last-test-dat-set! tabdat (make-hash-table))
(dboard:tabdat-allruns-set! tabdat '())
(dboard:tabdat-allruns-by-id-set! tabdat (make-hash-table))
(dboard:tabdat-done-runs-set! tabdat '())
(dboard:tabdat-not-done-runs-set! tabdat '())
(dboard:tabdat-view-changed-set! tabdat #t)
(dboard:commondat-please-update-set! commondat #t)
(dboard:clear-run-id-update-hash)
(mark-for-update tabdat))
#:expand "NO" #:size "40x15")
(iup:button "Collapse" #:action (lambda (obj)
(debug:catch-and-dump
(lambda ()
(let ((myname (iup:attribute obj "TITLE")))
(if (equal? myname "Collapse")
|
| ︙ | | | ︙ | |
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
|
exn
(begin
(debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" 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 dbdir "/*.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 (common:file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
|
|
|
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
|
exn
(begin
(debug:print 2 *default-log-port* "WARNING: error in accessing databases in get-youngest-run-db-mod-time: "
((condition-property-accessor 'exn 'message) exn) " db-dir="dbdir ", exn=" exn)
(current-seconds)) ;; something went wrong - just print an error and return current-seconds
(common:max (map (lambda (filen)
(file-modification-time filen))
(cons (conc dbdir "/main.db") (glob (conc dbdir "/?.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 (common:file-exists? monitor-db-path))
(file-modification-time monitor-db-path)
-1)))
|
| ︙ | | | ︙ | |
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
|
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(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)))
|
|
|
|
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
|
(dwg (dboard:tabdat-drawing tabdat))
(mtx (dboard:tabdat-runs-mutex tabdat))
(vch (dboard:tabdat-view-changed tabdat)))
(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)))
|
| ︙ | | | ︙ | |
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
|
(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 "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)
;; add 60 to make room for the graph
(vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
(mutex-unlock! mtx)
;; (set! run-start-row (+ max-row 2))
;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
;; get tests in list sorted by event time ascending
(let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
(tests-tal (cdr hierdat))
(test-num 1))
(let ((iterated (> (length test-ids) 1))
|
|
|
|
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
|
(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 "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)
;; add 60 to make room for the graph
(vg:instantiate drawing "runslib" run-full-name run-full-name 8 (- (calc-y curr-run-start-row) (+ 5 graph-height run-to-run-margin)))
;; (mutex-unlock! mtx)
;; (set! run-start-row (+ max-row 2))
;; (dboard:tabdat-start-row-set! tabdat (+ new-run-start-row 1))
;; get tests in list sorted by event time ascending
(let testsloop ((test-ids (car hierdat)) ;; loop on tests (NOTE: not items!)
(tests-tal (cdr hierdat))
(test-num 1))
(let ((iterated (> (length test-ids) 1))
|
| ︙ | | | ︙ | |
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
|
(ulx (list-ref new-xtnts 2))
(uly (list-ref new-xtnts 3))
(outln (vg:make-rect-obj -5 lly ulx uly
text: run-full-name
line-color: (vg:rgb->number 255 0 255 a: 128))))
; (vg:components-get-extents d1 c1)))
;; this is the box around the run
(mutex-lock! mtx)
(vg:add-obj-to-comp runcomp outln)
(mutex-unlock! mtx)
;; this is where we have enough info to place the graph
(dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
))
;; end of the run handling loop
(if (not (dboard:tabdat-layout-update-ok tabdat))
|
|
|
|
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
|
(ulx (list-ref new-xtnts 2))
(uly (list-ref new-xtnts 3))
(outln (vg:make-rect-obj -5 lly ulx uly
text: run-full-name
line-color: (vg:rgb->number 255 0 255 a: 128))))
; (vg:components-get-extents d1 c1)))
;; this is the box around the run
;; (mutex-lock! mtx)
(vg:add-obj-to-comp runcomp outln)
;; (mutex-unlock! mtx)
;; this is where we have enough info to place the graph
(dboard:graph commondat tabdat tab-num -5 (+ uly 10) ulx (+ uly graph-height 3) run-start run-end timescale maptime run-full-name canvas-margin)
(dboard:tabdat-max-row-set! tabdat (+ (dboard:tabdat-max-row tabdat)(quotient (+ graph-height 40 3) row-height)))
;; (vg:instance-move drawing run-full-name 0 (dboard:tabdat-max-row tabdat))
))
;; end of the run handling loop
(if (not (dboard:tabdat-layout-update-ok tabdat))
|
| ︙ | | | ︙ | |
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
|
;; (lambda ()
;; (dashboard:runs-tab-updater commondat 1))
;; tab-num: 2)
(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))))
;; (debug:print 0 *default-log-port* "Starting updaters")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
|
|
|
|
|
|
|
|
|
|
|
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
|
;; (lambda ()
;; (dashboard:runs-tab-updater commondat 1))
;; tab-num: 2)
(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))))
;; (debug:print 0 *default-log-port* "Starting updaters")
(let ((th1 (make-thread (lambda ()
(thread-sleep! 1)
(dboard:common-run-curr-updaters commondat 0) ;; force update of summary tab
) "update buttons once"))
(th2 (make-thread iup:main-loop "Main loop")))
|
| ︙ | | | ︙ | |
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
|
;; Sync to tmp only if in read-only mode.
(define (sync-db-to-tmp tabdat)
(let* ((db-file "./.mtdb/main.db"))
(if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
(begin
(db:multi-db-sync (db:setup #f) 'old2new)
(set! last-copy-time (current-seconds))
)
)
)
)
;; ########################### top level code ########################
|
|
|
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
|
;; Sync to tmp only if in read-only mode.
(define (sync-db-to-tmp tabdat)
(let* ((db-file "./.mtdb/main.db"))
(if (and (not (file-write-access? db-file)) ( > (current-seconds) (+ last-copy-time 5)))
(begin
(db:multi-db-sync (db:setup) 'old2new)
(set! last-copy-time (current-seconds))
)
)
)
)
;; ########################### top level code ########################
|
| ︙ | | | ︙ | |