︙ | | | ︙ | |
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2016
Usage: dashboard [options]
-h : this help
-test run-id,test-id : control test identified by testid
-skip-version-check : skip the version check
Misc
-rows R : set number of rows
-cols C : set number of columns
"))
;; -server host:port : connect to host:port instead of db access
|
>
|
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2016
Usage: dashboard [options]
-h : this help
-test run-id,test-id : control test identified by testid
-skip-version-check : skip the version check
-use-db-cache : access database via cache
Misc
-rows R : set number of rows
-cols C : set number of columns
"))
;; -server host:port : connect to host:port instead of db access
|
︙ | | | ︙ | |
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
|
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
"-use-local"
"-skip-version-check"
)
args:arg-hash
0))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
please-update
tabdats
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
)
(list "-h"
"-use-server"
"-guimonitor"
"-main"
"-v"
"-q"
"-use-db-cache"
"-skip-version-check"
)
args:arg-hash
0))
(if (not (null? remargs))
(begin
(print "Unrecognised arguments: " (string-intersperse remargs " "))
(exit)))
(if (args:get-arg "-h")
(begin
(print help)
(exit)))
;; TODO: Move this inside (main)
;;
(if (not (launch:setup))
(begin
(print "Failed to find megatest.config, exiting")
(exit 1)))
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
(if (file-write-access? (conc *toppath* "/megatest.db"))
(thread-start! (make-thread common:watchdog "Watchdog thread"))
(if (not (args:get-arg "-use-db-cache"))
(begin
(debug:print-info 0 *default-log-port* "Forcing db-cache mode due to read-only access to megatest.db")
(hash-table-set! args:arg-hash "-use-db-cache" #t))))
;; data common to all tabs goes here
;;
(defstruct dboard:commondat
((curr-tab-num 0) : number)
please-update
tabdats
|
︙ | | | ︙ | |
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
((searchpatts (make-hash-table)) : hash-table) ;;
((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
(target #f)
(test-patts #f)
;; db info to file the .db files for the area
(dbdir #f)
(dbfpath #f)
(dbkeys #f)
((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
(monitor-db-path #f) ;; where to find monitor.db
ro ;; is the database read-only?
;; tests data
((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
;; runs tree
((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
(runs-tree #f)
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
;; runs-summary tab state
((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
|
>
>
|
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
|
((searchpatts (make-hash-table)) : hash-table) ;;
((state-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATE => #t/#f for display control
((status-ignore-hash (make-hash-table)) : hash-table) ;; hash of STATUS => #t/#f
(target #f)
(test-patts #f)
;; db info to file the .db files for the area
(access-mode (db:get-access-mode)) ;; use cached db or not
(dbdir #f)
(dbfpath #f)
(dbkeys #f)
((last-db-update (make-hash-table)) : hash-table) ;; last db file timestamp
(monitor-db-path #f) ;; where to find monitor.db
ro ;; is the database read-only?
;; tests data
((num-tests 10) : number) ;; total number of tests to show (used in the old runs display)
;; runs tree
((path-run-ids (make-hash-table)) : hash-table) ;; path (target / runname) => id
(runs-tree #f)
((runs-tree-ht (make-hash-table)) : hash-table) ;; track which targets added to tree (merge functionality with path-run-ids?)
;; tab data
((view-changed #t) : boolean)
((xadj 0) : number) ;; x slider number (if using canvas)
((yadj 0) : number) ;; y slider number (if using canvas)
;; runs-summary tab state
((runs-summary-modes '((one-run . "Show One Run") (xor-two-runs . "XOR Two Runs") (xor-two-runs-hide-clean . "XOR; Hide Clean")) ) : list)
|
︙ | | | ︙ | |
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
|
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
(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")))
(dboard:tabdat-tot-runs-set! tabdat (rmt:get-num-runs "%"))
)
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
|
|
|
|
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
|
(dboard:tabdat-dbdir-set! tabdat (db:dbfile-path #f)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/.db"))
(dboard:tabdat-dbfpath-set! tabdat (db:dbfile-path 0))
(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 (db:dispatch-query (db:get-access-mode) rmt:get-keys db:get-keys))
(dboard:tabdat-dbkeys-set! tabdat (append (dboard:tabdat-keys tabdat) (list "runname")))
(dboard:tabdat-tot-runs-set! tabdat (db:dispatch-query (db:get-access-mode) rmt:get-num-runs db:get-num-runs "%"))
)
;; RADT => Matrix defstruct addition
(defstruct dboard:graph-dat
((id #f) : string)
((color #f) : vector)
((flag #t) : boolean)
|
︙ | | | ︙ | |
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
|
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((num-to-get
(let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
(if num-tests-from-config
(begin
(BB> "override num-tests 100 -> "num-tests-from-config)
(string->number num-tests-from-config))
100)))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
|
>
|
|
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
|
;; This is roughly the same as dboard:get-tests-dat, should merge them if possible
;;
;; gets all the tests for run-id that match testnamepatt and key-vals, merges them
;;
;; NOTE: Yes, this is used
;;
(define (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(num-to-get
(let ((num-tests-from-config (configf:lookup *configdat* "setup" "num-tests-to-get")))
(if num-tests-from-config
(begin
(BB> "override num-tests 100 -> "num-tests-from-config)
(string->number num-tests-from-config))
100)))
(states (hash-table-keys (dboard:tabdat-state-ignore-hash tabdat)))
|
︙ | | | ︙ | |
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
|
(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 do-not-use-db-file-timestamps
(>= (common:lazy-modification-time db-path) last-update))
(rmt:get-tests-for-run run-id testnamepatt states statuses ;; run-id testpatt states statuses
(dboard:rundat-run-data-offset run-dat)
num-to-get
(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)
(dboard:rundat-tests run-dat)))
|
>
|
|
|
|
|
|
|
|
|
|
|
|
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
|
(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 do-not-use-db-file-timestamps
(>= (common:lazy-modification-time db-path) last-update))
(db:dispatch-query access-mode rmt:get-tests-for-run db:get-tests-for-run
run-id testnamepatt states statuses ;; run-id testpatt states statuses
(dboard:rundat-run-data-offset run-dat)
num-to-get
(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)
(dboard:rundat-tests run-dat)))
|
︙ | | | ︙ | |
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
|
;; 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 (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((keys (rmt:get-keys))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(allruns (rmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (rmt:get-runs-by-patt keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
>
|
>
|
>
|
|
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
|
;; 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 (update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(keys (db:dispatch-query access-mode rmt:get-keys db:get-keys))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(allruns (db:dispatch-query access-mode rmt:get-runs db:get-runs
runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
keys "%" #f #f #f #f last-runs-update));;'("id" "runname")
(header (db:get-header allruns))
(runs (db:get-rows allruns)) ;; RA => Filtered as per runpatt selected
(runs-tree (db:get-rows allruns-tree)) ;; RA => Returns complete list of runs
(start-time (current-seconds))
(runs-hash (let ((ht (make-hash-table)))
(for-each (lambda (run)
(hash-table-set! ht (db:get-value-by-header run header "id") run))
|
︙ | | | ︙ | |
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
|
(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)
|
|
|
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
|
(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)) ;; (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db: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)
|
︙ | | | ︙ | |
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
|
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (rmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header)))))
|
|
|
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
|
(let ((newval (car values)))
(iup:attribute-set! lb "VALUE" newval)
newval))))))
(define (dashboard:update-target-selector tabdat #!key (action-proc #f))
(let* ((runconf-targs (common:get-runconfig-targets))
(key-lbs (dboard:tabdat-key-listboxes tabdat))
(db-target-dat (db:dispatch-query (db:get-access-mode) rmt:get-targets db:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(list->vector
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header)))))
|
︙ | | | ︙ | |
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
|
(dashboard:update-run-command tabdat)))
;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
(let* ((tb (dboard:tabdat-runs-tree tabdat))
(runconf-targs (common:get-runconfig-targets))
(db-target-dat (rmt:get-targets))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header))))
(all-targets (append (list (munge-target (string-intersperse
(map (lambda (x) "%") header)
"/")))
(map vector->list db-targets)
(map munge-target
runconf-targs)
)))
(for-each
(lambda (target)
(tree:add-node tb "Runs" target)) ;; (append key-vals (list run-name))
all-targets)))
;; Run controls panel
;;
(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
|
|
>
>
>
>
>
|
>
|
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
|
(dashboard:update-run-command tabdat)))
;; used by run-controls
;;
(define (dashboard:update-tree-selector tabdat #!key (action-proc #f))
(let* ((tb (dboard:tabdat-runs-tree tabdat))
(runconf-targs (common:get-runconfig-targets))
(db-target-dat (db:dispatch-query (db:get-access-mode) rmt:get-targets db:get-targets))
(runs-tree-ht (dboard:tabdat-runs-tree-ht tabdat))
(header (vector-ref db-target-dat 0))
(db-targets (vector-ref db-target-dat 1))
(munge-target (lambda (x) ;; create a target vector from a string. Pad with na if needed.
(take (append (string-split x "/")
(make-list (length header) "na"))
(length header))))
(all-targets (append (list (munge-target (string-intersperse
(map (lambda (x) "%") header)
"/")))
(map vector->list db-targets)
(map munge-target
runconf-targs)
)))
(for-each
(lambda (target)
(if (not (hash-table-ref/default runs-tree-ht target #f))
;; (let ((existing (tree:find-node tb target)))
;; (if (not existing)
(begin
(tree:add-node tb "Runs" target) ;; (append key-vals (list run-name))
(hash-table-set! runs-tree-ht target #t))))
all-targets)))
;; Run controls panel
;;
(define (dashboard:run-controls commondat tabdat #!key (tab-num #f))
(let* ((targets (make-hash-table))
(test-records (make-hash-table))
|
︙ | | | ︙ | |
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
|
(define (tree-path->run-id tabdat path)
(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
(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
#f #f ;; sort-by sort-order
#f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
|
>
|
>
|
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
|
(define (tree-path->run-id tabdat path)
(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* ((access-mode (dboard:tabdat-access-mode tabdat))
(tdat (if run-id (db:dispatch-query access-mode rmt:get-tests-for-run db: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
#f #f ;; sort-by sort-order
#f ;; get all? "id,testname,item_path,state,status,event_time,run_duration" ;; qryval
|
︙ | | | ︙ | |
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
|
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
(define (dboard:update-tree tabdat runs-hash runs-header tb)
(let* ((run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(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)))))
(changed #f)
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(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))
(dboard:tabdat-keys tabdat)))
(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 (dboard:tabdat-path-run-ids tabdat) run-path #f))
(begin
(hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
;; (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! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)))
(define (dashboard:tests-ht->tests-dat tests-ht)
(reverse
(sort
(hash-table-values tests-ht)
(lambda (a b)
(let ((a-test-name (db:test-get-testname a))
(a-item-path (db:test-get-item-path a))
(b-test-name (db:test-get-testname b))
(b-item-path (db:test-get-item-path b)))
(cond
((< 0 (string-compare3 a-test-name b-test-name)) #t)
((> 0 (string-compare3 a-test-name b-test-name)) #f)
((< 0 (string-compare3 a-item-path b-item-path)) #t)
(else #f)))))))
(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (rmt:get-key-vals run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
(tests-dat (dashboard:tests-ht->tests-dat tests-ht))
(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
(hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
|
>
|
>
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
|
(define (dashboard:safe-cadr-assoc name lst)
(let ((res (assoc name lst)))
(if (and res (> (length res) 1))
(cadr res)
#f)))
(define (dboard:update-tree tabdat runs-hash runs-header tb)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
(lambda (a b)
(let* ((record-a (hash-table-ref runs-hash a))
(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)))))
(changed #f)
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
(dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update)))
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(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))
(dboard:tabdat-keys tabdat)))
(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))))
(if (not (hash-table-ref/default (dboard:tabdat-path-run-ids tabdat) run-path #f))
;; (let ((existing (tree:find-node tb run-path)))
;; (if (not existing)
(begin
(hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; (iup:attribute-set! (dboard:tabdat-runs-matrix tabdat)
;; (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! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids)))
(define (dashboard:tests-ht->tests-dat tests-ht)
(reverse
(sort
(hash-table-values tests-ht)
(lambda (a b)
(let ((a-test-name (db:test-get-testname a))
(a-item-path (db:test-get-item-path a))
(b-test-name (db:test-get-testname b))
(b-item-path (db:test-get-item-path b)))
(cond
((< 0 (string-compare3 a-test-name b-test-name)) #t)
((> 0 (string-compare3 a-test-name b-test-name)) #f)
((< 0 (string-compare3 a-item-path b-item-path)) #t)
(else #f)))))))
(define (dashboard:run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (rmt:get-key-vals run-id)) ;; (db:dispatch-query (db:get-access-mode) rmt:get-key-vals db:get-key-vals run-id))
(testnamepatt (or (dboard:tabdat-test-patts tabdat) "%/%"))
(tests-ht (dboard:get-tests-for-run-duplicate tabdat run-id run testnamepatt key-vals))
(tests-dat (dashboard:tests-ht->tests-dat tests-ht))
(tests-mindat (dcommon:minimize-test-data tests-dat))) ;; reduces data for display
(dboard:tabdat-last-runs-update-set! tabdat (- (current-seconds) 2))
(hash-table-set! (dboard:tabdat-last-test-dat tabdat) run-id tests-dat)
(hash-table-set! (dboard:tabdat-run-update-times tabdat) run-id (- (current-seconds) 10))
|
︙ | | | ︙ | |
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
|
(dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
(dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
(define (dashboard:get-runs-hash tabdat)
(let* ((last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(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))
runs) ht)))
runs-hash))
(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
(if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
(dashboard:do-update-rundat tabdat))
(dboard:runs-summary-control-panel-updater tabdat)
(let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(runs-hash (dashboard:get-runs-hash tabdat))
;; (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))
|
>
|
>
|
>
>
|
|
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
|
(dashboard:run-id->tests-mindat src-run-id tabdat runs-hash)
(dashboard:run-id->tests-mindat dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
(define (dashboard:get-runs-hash tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:dispatch-query access-mode rmt:get-runs-by-patt db:get-runs-by-patt
(dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(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))
runs) ht)))
runs-hash))
(define (dashboard:runs-summary-updater commondat tabdat tb cell-lookup run-matrix)
(if (dashboard:database-changed? commondat tabdat context-key: 'runs-summary-rundat)
(dashboard:do-update-rundat tabdat))
(dboard:runs-summary-control-panel-updater tabdat)
(let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:dispatch-query (dboard:tabdat-access-mode tabdat)
rmt:get-runs-by-patt db:get-runs-by-patt
(dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(runs (vector-ref runs-dat 1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(runs-hash (dashboard:get-runs-hash tabdat))
;; (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))
|
︙ | | | ︙ | |
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
|
(iup:attribute-set! this-button "BGCOLOR" sel-color)
(iup:attribute-set! this-button "BGCOLOR" nonsel-color))
(loop (cdr buttons-left) (cdr modes-left))))))
(define (dboard:runs-summary-xor-labels-updater tabdat)
(let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
(dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
(mode (dboard:tabdat-runs-summary-mode tabdat)))
(when (and source-runname-label dest-runname-label)
(case mode
((xor-two-runs xor-two-runs-hide-clean)
(let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
(prev-run-id (dboard:tabdat-prev-run-id tabdat))
(curr-runname (if curr-run-id
(rmt:get-run-name-from-id curr-run-id)
"None"))
(prev-runname (if prev-run-id
(rmt:get-run-name-from-id prev-run-id)
"None")))
(iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
(iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
(else
(iup:attribute-set! source-runname-label "TITLE" "")
(iup:attribute-set! dest-runname-label "TITLE" ""))))))
|
|
>
|
|
|
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
|
(iup:attribute-set! this-button "BGCOLOR" sel-color)
(iup:attribute-set! this-button "BGCOLOR" nonsel-color))
(loop (cdr buttons-left) (cdr modes-left))))))
(define (dboard:runs-summary-xor-labels-updater tabdat)
(let ((source-runname-label (dboard:tabdat-runs-summary-source-runname-label tabdat))
(dest-runname-label (dboard:tabdat-runs-summary-dest-runname-label tabdat))
(mode (dboard:tabdat-runs-summary-mode tabdat))
(access-mode (db:get-access-mode)))
(when (and source-runname-label dest-runname-label)
(case mode
((xor-two-runs xor-two-runs-hide-clean)
(let* ((curr-run-id (dboard:tabdat-curr-run-id tabdat))
(prev-run-id (dboard:tabdat-prev-run-id tabdat))
(curr-runname (if curr-run-id
(db:dispatch-query access-mode rmt:get-run-name-from-id db:get-run-name-from-id curr-run-id)
"None"))
(prev-runname (if prev-run-id
(db:dispatch-query access-mode rmt:get-run-name-from-id db:get-run-name-from-id prev-run-id)
"None")))
(iup:attribute-set! source-runname-label "TITLE" (conc " SRC: "prev-runname" "))
(iup:attribute-set! dest-runname-label "TITLE" (conc "DEST: "curr-runname" "))))
(else
(iup:attribute-set! source-runname-label "TITLE" "")
(iup:attribute-set! dest-runname-label "TITLE" ""))))))
|
︙ | | | ︙ | |
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
|
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(BB> "click-cb: obj="obj" lin="lin" col="col" status="status)
;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (rmt:get-run-info run-id))
(target (rmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (rmt:tasks-get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path)))
(status-chars (char-set->list (string->char-set status)))
(testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
(BB> "status-chars=["status-chars"] status=["status"]")
(cond
|
>
|
|
|
|
>
|
|
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
|
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(BB> "click-cb: obj="obj" lin="lin" col="col" status="status)
;; status is corrupted on Brandon's home machine. will have to wait until after shutdown to see if it is still broken in PDX SLES
(let* ((access-mode (db:get-access-mode))
(toolpath (car (argv)))
(key (conc lin ":" col))
(test-id (hash-table-ref/default cell-lookup key -1))
(run-id (dboard:tabdat-curr-run-id tabdat))
(run-info (db:dispatch-query access-mode rmt:get-run-info db:get-run-info run-id))
(target (db:dispatch-query access-mode rmt:get-target db:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (db:dispatch-query access-mode rmt:tasks-get-last tasks:get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(test-info (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id))
(item-path (db:test-get-item-path test-info))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path)))
(status-chars (char-set->list (string->char-set status)))
(testpanel-cmd (conc toolpath " -test " (dboard:tabdat-curr-run-id tabdat) "," test-id " &")))
(BB> "status-chars=["status-chars"] status=["status"]")
(cond
|
︙ | | | ︙ | |
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
|
#:expand "NO"
#:fontsize btn-fontsz
#:button-cb
(lambda (obj a pressed x y btn . rem)
;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
(if (substring-index "3" btn)
(if (eq? pressed 1)
(let* ((toolpath (car (argv)))
(buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(run-info (rmt:get-run-info run-id))
(target (rmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-name (db:test-get-testname (rmt:get-test-info-by-id run-id test-id)))
(testpatt (let ((tlast (rmt:tasks-get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
(item-path (db:test-get-item-path (rmt:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
(iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
|
>
|
|
|
>
|
|
>
|
|
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
|
#:expand "NO"
#:fontsize btn-fontsz
#:button-cb
(lambda (obj a pressed x y btn . rem)
;; (print "pressed= " pressed " x= " x " y= " y " rem=" rem " btn=" btn " string? " (string? btn))
(if (substring-index "3" btn)
(if (eq? pressed 1)
(let* ((access-mode (db:get-access-mode))
(toolpath (car (argv)))
(buttndat (hash-table-ref (dboard:tabdat-buttondat runs-dat) button-key))
(test-id (db:test-get-id (vector-ref buttndat 3)))
(run-id (db:test-get-run_id (vector-ref buttndat 3)))
(run-info (db:dispatch-query access-mode rmt:get-run-info db:get-run-info run-id))
(target (db:dispatch-query access-mode rmt:get-target db:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (db:dispatch-query access-mode rmt:tasks-get-last tasks:get-last target runname)))
(if tlast
(let ((tpatt (tasks:task-get-testpatt tlast)))
(if (member tpatt '("0" 0)) ;; known bad historical value - remove in 2017
"%"
tpatt))
"%")))
;; Why are we getting the test-info over again? run-id and test-id are the same right?
(item-path (db:test-get-item-path test-info)) ;; (db:dispatch-query access-mode rmt:get-test-info-by-id db:get-test-info-by-id run-id test-id)))
(item-test-path (conc test-name "/" (if (equal? item-path "")
"%"
item-path))))
(iup:show (dashboard:popup-menu run-id test-id target runname test-name testpatt item-test-path) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
|
︙ | | | ︙ | |
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
|
;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(tasks:open-db)
(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))
(file-modification-time monitor-db-path)
-1)))
|
>
|
|
|
|
|
|
|
|
|
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
|
;; (define *monitor-db-path* #f)
(define *last-monitor-update-time* 0)
;; Force creation of the db in case it isn't already there.
(tasks:open-db)
(define (dashboard:get-youngest-run-db-mod-time tabdat)
(let ((dbpath (dboard:tabdat-dbdir 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 dbpath "/*.db")(conc dbpath "/*-shm")(conc dbpath "/*-wal")))))))
(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))
(file-modification-time monitor-db-path)
-1)))
|
︙ | | | ︙ | |
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
|
(lambda (a b)
(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (rmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(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))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
|
>
|
>
>
|
|
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
|
(lambda (a b)
(< (db:test-get-event_time (hash-table-ref testsdat (car a)))
(db:test-get-event_time (hash-table-ref testsdat (car b))))))))))
;; run times tab data updater
;;
(define (dashboard:run-times-tab-run-data-updater commondat tabdat tab-num)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(last-runs-update (dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:dispatch-query access-mode
rmt:get-runs-by-patt db:get-runs-by-patt
(dboard:tabdat-keys tabdat) "%" #f #f #f #f last-runs-update))
(runs-header (vector-ref runs-dat 0)) ;; 0 is header, 1 is list of records
(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))
(run-ids (sort (filter number? (hash-table-keys runs-hash))
|
︙ | | | ︙ | |
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
|
(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))
(dboard:tabdat-keys tabdat)))
(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 (dboard:tabdat-path-run-ids tabdat) run-path #f))
(begin
(hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; 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! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids))
;; (print "Updating rundat")
(if (dboard:tabdat-keys tabdat) ;; have keys yet?
(let* ((num-keys (length (dboard:tabdat-keys tabdat)))
|
|
|
|
|
|
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
|
(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))
(dboard:tabdat-keys tabdat)))
(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 (dboard:tabdat-path-run-ids tabdat) run-path #f))
(begin
(hash-table-set! (dboard:tabdat-run-keys tabdat) run-id run-path)
;; 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! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; (set! colnum (+ colnum 1))
))))
run-ids))
;; (print "Updating rundat")
(if (dboard:tabdat-keys tabdat) ;; have keys yet?
(let* ((num-keys (length (dboard:tabdat-keys tabdat)))
|
︙ | | | ︙ | |