| ︙ | | |
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
|
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
|
-
+
-
-
+
-
-
+
+
+
+
+
+
|
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2016
Usage: dashboard [options]
-h : this help
-h : this help
-server host:port : connect to host:port instead of db access
-test run-id,test-id : control test identified by testid
-xterm run-id,test-id : Start a new xterm with specified run-id and test-id
-guimonitor : control panel for runs
|
| ︙ | | |
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
-
+
|
;; gets and calls updater based on curr-tab-num
(define (dboard:common-run-curr-updaters commondat #!key (tab-num #f))
(if (dboard:common-get-tabdat commondat tab-num: tab-num) ;; only update if there is a tabdat
(let* ((tnum (or tab-num (dboard:commondat-curr-tab-num commondat)))
(updaters (hash-table-ref/default (dboard:commondat-updaters commondat)
tnum
'())))
(debug:print 0 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(debug:print 4 *default-log-port* "Found these updaters: " updaters " for tab-num: " tnum)
(for-each
(lambda (updater)
(debug:print 3 *default-log-port* "Running " updater)
(updater)
)
updaters))))
|
| ︙ | | |
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
|
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
-
+
-
-
-
+
|
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
;; data for each specific tab goes here
;;
(defstruct dboard:tabdat
allruns
allruns-by-id
;; runs
allruns ;; list of dboard:rundat records
allruns-by-id ;; hash of run-id -> dboard:rundat records
header ;; header for decoding the run records
keys ;; keys for this run (i.e. target components)
numruns
;; Runs view
buttondat
item-test-names
;; Canvas and drawing data
cnv
cnv-obj
drawing
draw-cache ;;
;; Controls used to launch runs etc.
command
command-tb
;; Selector variables
curr-run-id
curr-test-ids
db
curr-run-id ;; current row to display in Run summary view
curr-test-ids ;; used only in dcommon:run-update which is used in newdashboard
filters-changed ;; to to indicate that the user changed filters for this tab
hide-empty-runs
hide-not-hide ;; toggle for hide/not hide empty runs
hide-not-hide-button
;; db info to file the .db files for the area
dbdir
dbfpath
dbkeys
drawing
filters-changed
header
hide-empty-runs
hide-not-hide ;; toggle for hide/not hide
hide-not-hide-button
item-test-names
keys
last-update ;; last time rmt:get-tests-for-run was used to get data
last-update ;; last time rmt:get-tests-for-run was used to get data
logs-textbox
monitor-db-path
numruns
|
| ︙ | | |
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
|
+
-
+
|
)
;; used to keep the rundata from rmt:get-tests-for-run
;; in sync.
;;
(defstruct dboard:rundat
run
tests-drawn
tests
tests
key-vals
last-update
)
(define (dboard:runsdat-make-init)
(make-dboard:runsdat
runs-index: (make-hash-table)
|
| ︙ | | |
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
|
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
|
+
+
+
+
+
+
+
+
+
+
|
#:name "Runs"
#:expand "YES"
#:addexpanded "NO"
#:selection-cb
(lambda (obj id state)
;; (print "obj: " obj ", id: " id ", state: " state)
(let* ((run-path (tree:node->path obj id))
;; change this to store run-path appropriately as selector
(run-id (tree-path->run-id tabdat (cdr run-path))))
(print "run-path: " run-path)
(if (number? run-id)
(begin
(dboard:tabdat-curr-run-id-set! tabdat run-id)
;; (dashboard:update-run-summary-tab)
)
|
| ︙ | | |
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
|
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
|
-
+
+
+
+
|
(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)))))
(tb (dboard:tabdat-runs-tree tabdat)))
(tb (dboard:tabdat-runs-tree tabdat))
(num-runs (length (hash-table-keys runs-hash)))
(run-num 0)
(update-start-time (current-seconds)))
;; fill in the tree
(if tb (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))
|
| ︙ | | |
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
|
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
|
+
-
+
+
+
-
+
-
+
|
;; 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))
;;
(if (and tabdat
(dboard:tabdat-view-changed tabdat))
(let* ((drawing (dboard:tabdat-drawing tabdat))
(runslib (vg:get/create-lib drawing "runslib"))) ;; creates and adds lib
(runslib (vg:get/create-lib drawing "runslib")) ;; creates and adds lib
(compute-start (current-seconds)))
(vg:drawing-xoff-set! drawing (dboard:tabdat-xadj tabdat))
(vg:drawing-yoff-set! drawing (dboard:tabdat-yadj tabdat))
(print "Updating rundat")
(update-rundat tabdat
(time (update-rundat tabdat
"%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
100 ;; (dboard:tabdat-numruns tabdat)
"%" ;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "item-name" "%")
(let ((res '()))
(for-each (lambda (key)
(if (not (equal? key "runname"))
(let ((val (hash-table-ref/default (dboard:tabdat-searchpatts tabdat) key #f)))
(if val (set! res (cons (list key val) res))))))
(dboard:tabdat-dbkeys tabdat))
res))
res)))
(let ((allruns (dboard:tabdat-allruns tabdat))
(rowhash (make-hash-table)) ;; store me in tabdat
(cnv (dboard:tabdat-cnv tabdat)))
(print "allruns: " allruns)
(let-values (((sizex sizey sizexmm sizeymm) (canvas-size cnv))
((originx originy) (canvas-origin cnv)))
;; (print "allruns: " allruns)
|
| ︙ | | |
2401
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
2433
2434
2435
2436
2437
2438
2439
2440
2441
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
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
|
2434
2435
2436
2437
2438
2439
2440
2441
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
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
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
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
|
-
+
+
+
+
+
-
+
+
+
+
+
+
+
+
-
+
-
-
+
+
-
+
-
+
-
+
|
(run-end (dboard:min-max > (map (lambda (t)(+ (db:test-get-event_time t)(db:test-get-run_duration t))) testsdat)))
(timeoffset (- (+ 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
(maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset)))))
(maptime (lambda (tsecs)(* timescale (+ tsecs timeoffset))))
(num-tests (length hierdat))
(test-num 0)
(tot-tests (length testsdat)))
(set! run-num (+ run-num 1))
;; (print "timescale: " timescale " timeoffset: " timeoffset " sizex: " sizex " originx: " originx)
(vg:add-comp-to-lib runslib run-full-name runcomp)
(set! run-start-row (+ max-row 2))
(set! start-row run-start-row)
;; this is the run title. move this into the box
;; (let ((x 10)
;; (y (- sizey (* start-row row-height))))
;; (vg:add-objs-to-comp runcomp (vg:make-text x y run-full-name font: "Helvetica -10"))
;; (dashboard:add-bar rowhash start-row x (+ x 100)))
(set! start-row (+ start-row 1))
;; get tests in list sorted by event time ascending
(for-each
(lambda (testdats)
(let ((test-objs '())
(iterated (> (length testdats) 1))
(first-rownum #f)
(num-items (length testdats)))
(num-items (length testdats))
(item-num 0))
(set! test-num (+ test-num 1))
(for-each
(lambda (testdat)
(let* ((event-time (maptime (db:test-get-event_time testdat)))
(run-duration (* timescale (db:test-get-run_duration testdat)))
(end-time (+ event-time run-duration))
(test-name (db:test-get-testname testdat))
(item-path (db:test-get-item-path testdat))
(state (db:test-get-state testdat))
(status (db:test-get-status testdat))
(test-fullname (conc test-name "/" item-path))
(name-color (gutils:get-color-for-state-status state status)))
(set! item-num (+ item-num 1))
;; (print "event_time: " (db:test-get-event_time testdat) " mapped event_time: " event-time)
;; (print "run-duration: " (db:test-get-run_duration testdat) " mapped run_duration: " run-duration)
(if (> item-num 50)
(if (eq? 0 (modulo item-num 50))
(print "processing " run-num " of " num-runs " runs " item-num " of " num-items " of test " test-name ", " test-num " of " num-tests " tests")))
(let loop ((rownum run-start-row)) ;; (+ start-row 1)))
(set! max-row (max rownum max-row)) ;; track the max row used
(print "Allocating test")
(if (dashboard:row-collision rowhash rownum event-time end-time)
(time (if (dashboard:row-collision rowhash rownum event-time end-time)
(loop (+ rownum 1))
(let* ((lly (- sizey (* rownum row-height)))
(uly (+ lly row-height))
(obj (vg:make-rect-obj event-time lly end-time uly
fill-color: (vg:iup-color->number (car name-color))
text: (if iterated item-path test-name)
font: "Helvetica -10")))
;; (if iterated
;; (dashboard:add-bar rowhash (- rownum 1) event-time end-time num-rows: (+ 1 num-items))
(if (not first-rownum)
(begin
(dashboard:row-collision rowhash (- rownum 1) event-time end-time num-rows: num-items)
(set! first-rownum rownum)))
(dashboard:add-bar rowhash rownum event-time end-time)
(vg:add-objs-to-comp runcomp obj)
(set! test-objs (cons obj test-objs)))))
(vg:add-obj-to-comp runcomp obj)
(set! test-objs (cons obj test-objs))))))
;; (print "test-name: " test-name " event-time: " event-time " run-duration: " run-duration)
))
testdats)
;; If it is an iterated test put box around it now.
(if iterated
(let* ((xtents (vg:get-extents-for-objs drawing test-objs))
(llx (- (car xtents) 5))
(lly (- (cadr xtents) 10))
(ulx (+ 5 (caddr xtents)))
(uly (+ 0 (cadddr xtents))))
(dashboard:add-bar rowhash first-rownum llx ulx num-rows: num-items)
(vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly
text: (db:test-get-testname (car testdats))
font: "Helvetica -10"))))))
hierdat)
;; placeholder box
(set! max-row (+ max-row 1))
(let ((y (- sizey (* max-row row-height))))
(vg:add-objs-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
(vg:add-obj-to-comp runcomp (vg:make-rect-obj 0 y 0 y)))
;; instantiate the component
(let* ((extents (vg:components-get-extents drawing runcomp))
;; move the following into mapping functions in vg.scm
;; (deltax (- llx ulx))
;; (scalex (if (> deltax 0)(/ sizex deltax) 1))
;; (sllx (* scalex llx))
;; (offx (- sllx originx))
(new-xtnts (apply vg:grow-rect 5 5 extents))
(llx (list-ref new-xtnts 0))
(lly (list-ref new-xtnts 1))
(ulx (list-ref new-xtnts 2))
(uly (list-ref new-xtnts 3))
) ;; (vg:components-get-extents d1 c1)))
(vg:add-objs-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
(vg:add-obj-to-comp runcomp (vg:make-rect-obj llx lly ulx uly text: run-full-name))
(vg:instantiate drawing "runslib" run-full-name run-full-name 0 0))
(set! max-row (+ max-row 1)))))
allruns)
(vg:drawing-cnv-set! (dboard:tabdat-drawing tabdat)(dboard:tabdat-cnv tabdat)) ;; cnv-obj)
(canvas-clear! (dboard:tabdat-cnv tabdat)) ;; -obj)
(print "Number of objs: " (length (vg:draw (dboard:tabdat-drawing tabdat) #t)))
(dboard:tabdat-view-changed-set! tabdat #f)
|
| ︙ | | |
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
|
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
|
-
+
|
;; ease debugging by loading ~/.dashboardrc
(let ((debugcontrolf (conc (get-environment-variable "HOME") "/.dashboardrc")))
(if (file-exists? debugcontrolf)
(load debugcontrolf)))
(define (main)
(common:exit-on-version-changed)
(if (not (args:get-arg "-skip-version-check"))(common:exit-on-version-changed))
(let* ((commondat (dboard:commondat-make)))
;; Move this stuff to db.scm? I'm not sure that is the right thing to do...
(cond
((args:get-arg "-test") ;; run-id,test-id
(let* ((dat (let ((d (map string->number (string-split (args:get-arg "-test") ","))))
(if (> (length d) 1)
d
|
| ︙ | | |