1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
;;======================================================================
;; AREAS
;;======================================================================
(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
;; maps data from tabdat view-dat to the matrix
;; if input databases have changed, refresh view-dat
;; if filters have changed, refresh view-dat from input databases
;; if pivots have changed, refresh view-dat from input databases
(let* ((runs-hash (dashboard:areas-get-runs-hash tabdat))
(runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
(tree-path (dboard:tabdat-tree-path tabdat)))
(dboard:areas-update-tree tabdat runs-hash runs-header tb)
(print "Tree path: " tree-path)
(iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
(iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
(iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")
;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
(iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
(iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
(iup:attribute-set! run-matrix "1:1" (conc tree-path))
(iup:attribute-set! run-matrix "REDRAW" "ALL")))
;; (dashboard:areas-do-update-rundat tabdat) ;; )
;; (dboard:areas-summary-control-panel-updater tabdat)
;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
;; (runs-dat (mrmt: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:areas-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))
|
|
|
|
|
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
;;======================================================================
;; AREAS
;;======================================================================
(define (dashboard:areas-summary-updater commondat tabdat tb cell-lookup run-matrix)
;; maps data from tabdat view-dat to the matrix
;; if input databases have changed, refresh view-dat
;; if filters have changed, refresh view-dat from input databases
;; if pivots have changed, refresh view-dat from input databases
(let* ((runs-hash (dashboard:areas-get-runs-hash commondat tabdat))
(runs-header '("contour_name" "release" "iteration" "testsuite_mode" "id" "runname" "state" "status" "owner" "event_time"))
(tree-path (dboard:tabdat-tree-path tabdat)))
(dboard:areas-update-tree tabdat runs-hash runs-header tb)
(print "Tree path: " tree-path)
(iup:attribute-set! run-matrix "CLEARVALUE" "ALL") ;; NOTE: Was CONTENTS
(iup:attribute-set! run-matrix "CLEARATTRIB" "CONTENTS")
(iup:attribute-set! run-matrix "RESIZEMATRIX" "YES")
;; (if (> max-col (string->number (iup:attribute run-matrix "NUMCOL")))
(iup:attribute-set! run-matrix "NUMCOL" 10) ;; max-col ))
;; (let ((effective-max-row (if (< max-row max-visible) max-visible max-row)))
;; (if (> effective-max-row (string->number (iup:attribute run-matrix "NUMLIN")))
(iup:attribute-set! run-matrix "NUMLIN" 10) ;; effective-max-row )))
(iup:attribute-set! run-matrix "1:1" (conc tree-path))
(iup:attribute-set! run-matrix "REDRAW" "ALL")))
;; (dashboard:areas-do-update-rundat commondat tabdat) ;; )
;; (dboard:areas-summary-control-panel-updater tabdat)
;; (let* ((last-runs-update (dboard:tabdat-last-runs-update tabdat))
;; (runs-dat (db:get-runs-by-patt dbstruct (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:areas-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))
|
| ︙ | | | ︙ | |
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
|
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(debug:print-info 13 *default-log-port* "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 (mrmt:get-run-info run-id))
(target (mrmt:get-target run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (mrmt:get-test-info-by-id run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (mrmt: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 (mrmt: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 " &")))
(debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
(cond
|
>
|
|
|
|
|
|
|
145
146
147
148
149
150
151
152
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
|
;; Bummer - we dont have the global get/set api mapped in chicken
;; (let* ((modkeys (iup:global "MODKEYSTATE")))
;; (BB> "modkeys="modkeys))
(debug:print-info 13 *default-log-port* "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* ((dbstruct (dboard:get-dbstruct commondat #f))
(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:get-run-info dbstruct run-id))
(target (db:get-target dbstruct run-id))
(runname (db:get-value-by-header (db:get-rows run-info)
(db:get-header run-info) "runname"))
(test-info (db:get-test-info-by-id dbstruct run-id test-id))
(test-name (db:test-get-testname test-info))
(testpatt (let ((tlast (db:tasks-get-last dbstruct 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 (db:get-test-info-by-id dbstruct 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 " &")))
(debug:print-info 13 *default-log-port* "status-chars=["status-chars"] status=["status"]")
(cond
|
| ︙ | | | ︙ | |
253
254
255
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
285
286
287
288
|
(debug:catch-and-dump
(lambda () ;; check that areas-matrix is initialized before calling the updater
(if areas-matrix
(dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
"dashboard:areas-summary-updater")
)
(mutex-unlock! update-mutex)))
(runs-summary-control-panel (dashboard:areas-summary-control-panel tabdat)))
(dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
tb
areas-matrix)
(dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
;; 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:areas-update-rundat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(keys (dboard:tabdat-keys tabdat))
(last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
(allruns (mrmt:get-runs runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (mrmt:get-runs-by-patt keys "%" #f #f #f #f 0)) ;; 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))
|
|
|
>
|
|
|
254
255
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
285
286
287
288
289
290
|
(debug:catch-and-dump
(lambda () ;; check that areas-matrix is initialized before calling the updater
(if areas-matrix
(dashboard:areas-summary-updater commondat tabdat tb cell-lookup areas-matrix)))
"dashboard:areas-summary-updater")
)
(mutex-unlock! update-mutex)))
(runs-summary-control-panel (dashboard:areas-summary-control-panel commondat tabdat)))
(dboard:commondat-add-updater commondat areas-summary-updater tab-num: tab-num)
(dboard:tabdat-runs-tree-set! tabdat tb)
(iup:vbox
(iup:split
#:value 200
tb
areas-matrix)
(dboard:make-controls commondat tabdat extra-widget: runs-summary-control-panel))))
;; 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:areas-update-rundat commondat tabdat runnamepatt numruns testnamepatt keypatts)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(dbstruct (dboard:get-dbstruct commondat #f))
(keys (dboard:tabdat-keys tabdat))
(last-runs-update (- (dboard:tabdat-last-runs-update tabdat) 2))
(allruns (db:get-runs dbstruct runnamepatt numruns (dboard:tabdat-start-run-offset tabdat) keypatts))
;;(allruns-tree (mrmt:get-runs-by-patt (dboard:tabdat-keys tabdat) "%" #f #f #f #f))
(allruns-tree (db:get-runs-by-patt dbstruct keys "%" #f #f #f #f 0)) ;; 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))
|
| ︙ | | | ︙ | |
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
|
(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 (mrmt: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)
|
|
|
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
|
(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 (db:get-key-vals dbstruct 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)
|
| ︙ | | | ︙ | |
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
|
(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:areas-update-tree tabdat runs-hash header tb)))
;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat tabdat)
(dboard:areas-update-rundat
tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; generate key patterns from the target stored in tabdat
(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
(let ((fres (if (dboard:tabdat-target tabdat)
(let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
(map (lambda (k v)(list k v)) dbkeys ptparts))
(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))))))
dbkeys)
res))))
fres))))
(define (dashboard:areas-get-runs-hash tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (mrmt: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)))
|
|
>
|
>
|
|
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
|
(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:areas-update-tree tabdat runs-hash header tb)))
;; runs update-rundat using the various filters from the gui
;;
(define (dashboard:areas-do-update-rundat commondat tabdat)
(dboard:areas-update-rundat
commondat
tabdat
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "runname" "%")
(dboard:tabdat-numruns tabdat)
(hash-table-ref/default (dboard:tabdat-searchpatts tabdat) "test-name" "%/%")
;; generate key patterns from the target stored in tabdat
(let* ((dbkeys (dboard:tabdat-dbkeys tabdat)))
(let ((fres (if (dboard:tabdat-target tabdat)
(let ((ptparts (append (dboard:tabdat-target tabdat)(make-list (length dbkeys) "%"))))
(map (lambda (k v)(list k v)) dbkeys ptparts))
(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))))))
dbkeys)
res))))
fres))))
(define (dashboard:areas-get-runs-hash commondat tabdat)
(let* ((access-mode (dboard:tabdat-access-mode tabdat))
(dbstruct (dboard:get-dbstruct commondat #f))
(last-runs-update 0);;(dboard:tabdat-last-runs-update tabdat))
(runs-dat (db:get-runs-by-patt dbstruct (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)))
|
| ︙ | | | ︙ | |
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
|
;; open the area dbs, given list of areas that are "cared about"
;; areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
(let ((areas-ht (dboard:commondat-areas commondat)))
(for-each
(lambda (area-dat)
(db:dashboard-open-db areas (car area-dat)(cdr area-dat)))
areas)))
(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
(let* ((tree-path (dboard:tabdat-tree-path tabdat))
;; (access-mode (dboard:tabdat-access-mode tabdat))
|
|
|
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
|
;; open the area dbs, given list of areas that are "cared about"
;; areas: '( (area_name . path) ... ) ;; NOT necessarily the section [areas] from megatest.config
;;
(define (dboard:areas-open-areas commondat tabdat areas)
(let ((areas-ht (dboard:commondat-areas commondat)))
(for-each
(lambda (area-dat)
(db:dashboard-open-dbstruct areas (car area-dat)(cdr area-dat)))
areas)))
(define (dboard:areas-update-tree tabdat runs-hash runs-header tb)
(let* ((tree-path (dboard:tabdat-tree-path tabdat))
;; (access-mode (dboard:tabdat-access-mode tabdat))
|
| ︙ | | | ︙ | |
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
|
;; ;; userdata: (conc "run-id: " run-id))))
;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; ;; (set! colnum (+ colnum 1))
;; ))))
;; (append new-run-ids run-ids)))) ;; for-each run-id
))
(define (dashboard:areas-run-id->tests-mindat run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (mrmt: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))
(when (not run)
(debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
(debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
)
tests-mindat))
(define (dashboard:areas-runs-summary-xor-matrix-content tabdat runs-hash #!key (hide-clean #f))
(let* ((src-run-id (dboard:tabdat-prev-run-id tabdat))
(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:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info)
(iup:menu
(iup:menu-item
"Test Control Panel"
|
|
|
|
>
|
|
|
|
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
|
;; ;; userdata: (conc "run-id: " run-id))))
;; (hash-table-set! (dboard:tabdat-path-run-ids tabdat) run-path run-id)
;; ;; (set! colnum (+ colnum 1))
;; ))))
;; (append new-run-ids run-ids)))) ;; for-each run-id
))
(define (dashboard:areas-run-id->tests-mindat dbstruct run-id tabdat runs-hash)
(let* ((run (hash-table-ref/default runs-hash run-id #f))
(key-vals (db:get-key-vals dbstruct 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))
(when (not run)
(debug:print-info 13 *default-log-port* "ERROR: NO RUN FOR RUN-ID run-id="run-id)
(debug:print-info 13 *default-log-port* "runs-hash-> " (hash-table->alist runs-hash))
)
tests-mindat))
(define (dashboard:areas-runs-summary-xor-matrix-content commondat tabdat runs-hash #!key (hide-clean #f))
(let* ((dbstruct (dboard:get-dbstruct commondat #f))
(src-run-id (dboard:tabdat-prev-run-id tabdat))
(dest-run-id (dboard:tabdat-curr-run-id tabdat)))
(if (and src-run-id dest-run-id)
(dcommon:xor-tests-mindat
(dashboard:run-id->tests-mindat dbstruct src-run-id tabdat runs-hash)
(dashboard:run-id->tests-mindat dbstruct dest-run-id tabdat runs-hash)
hide-clean: hide-clean)
#f)))
(define (dashboard:areas-popup-menu run-id test-id target runname test-name testpatt item-test-path test-info)
(iup:menu
(iup:menu-item
"Test Control Panel"
|
| ︙ | | | ︙ | |
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
|
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
|
<
|
562
563
564
565
566
567
568
569
570
571
572
573
574
575
|
(lambda (obj)
(dcommon:examine-xterm run-id test-id)))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt " item-test-path
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED,NOT_STARTED"))))
|
| ︙ | | | ︙ | |
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
|
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
;; (mrmt:test-set-state-status-by-id run-id test-id "KILLREQ" #f #f)
|
<
|
634
635
636
637
638
639
640
641
642
643
644
645
646
647
|
" -runname " runname
" -testpatt " item-test-path
" -preclean -clean-cache"))))
(iup:menu-item
(conc "Kill " item-test-path)
#:action
(lambda (obj)
(common:run-a-command
(conc "megatest -set-state-status KILLREQ,n/a -target " target
" -runname " runname
" -testpatt " item-test-path
" -state RUNNING,REMOTEHOSTSTART,LAUNCHED"))))
(iup:menu-item
(conc "Delete data : " item-test-path)
|
| ︙ | | | ︙ | |
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
|
(or please-update-buttons
(and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
(> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel tabdat)
(let* ((summary-buttons ;; build buttons
(map
(lambda (mode-item)
(let* ((this-mode (car mode-item))
(this-mode-label (cdr mode-item)))
(iup:button this-mode-label
#:action
(lambda (obj)
(debug:catch-and-dump
(lambda ()
(dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
(dboard:areas-summary-control-panel-updater tabdat))
"runs summary control panel updater")))))
(dboard:tabdat-runs-summary-modes tabdat)))
(summary-buttons-hbox (apply iup:hbox summary-buttons))
(xor-runname-labels-hbox
(iup:hbox
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10" )))
(dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
temp-label
)
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10")))
(dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
temp-label))))
(dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
;; maybe wrap in a frame
(let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
(dboard:areas-summary-control-panel-updater tabdat)
res
)))
(define (dboard:areas-summary-control-panel-updater tabdat)
(dboard:areas-summary-xor-labels-updater tabdat)
(dboard:areas-summary-buttons-updater tabdat))
(define (dboard:areas-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
(mrmt:get-run-name-from-id curr-run-id)
"None"))
(prev-runname (if prev-run-id
(mrmt: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" ""))))))
|
|
|
|
|
|
|
|
|
>
|
|
|
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
|
(or please-update-buttons
(and ;; (> (current-milliseconds)(+ *last-recalc-ended-time* 150)) ;; can't use this - it needs to be tab specific
(> modtime (- last-db-update-time 3)) ;; add three seconds of margin
(> (current-seconds)(+ last-db-update-time 1)))))
;; setup buttons and callbacks to switch between modes in runs summary tab
;;
(define (dashboard:areas-summary-control-panel commondat tabdat)
(let* ((summary-buttons ;; build buttons
(map
(lambda (mode-item)
(let* ((this-mode (car mode-item))
(this-mode-label (cdr mode-item)))
(iup:button this-mode-label
#:action
(lambda (obj)
(debug:catch-and-dump
(lambda ()
(dboard:tabdat-runs-summary-mode-set! tabdat this-mode)
(dboard:areas-summary-control-panel-updater commondat tabdat))
"runs summary control panel updater")))))
(dboard:tabdat-runs-summary-modes tabdat)))
(summary-buttons-hbox (apply iup:hbox summary-buttons))
(xor-runname-labels-hbox
(iup:hbox
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10" )))
(dboard:tabdat-runs-summary-source-runname-label-set! tabdat temp-label)
temp-label
)
(let ((temp-label
(iup:label "" #:size "125x15" #:fontsize "10")))
(dboard:tabdat-runs-summary-dest-runname-label-set! tabdat temp-label)
temp-label))))
(dboard:tabdat-runs-summary-mode-buttons-set! tabdat summary-buttons)
;; maybe wrap in a frame
(let ((res (iup:vbox summary-buttons-hbox xor-runname-labels-hbox )))
(dboard:areas-summary-control-panel-updater commondat tabdat)
res
)))
(define (dboard:areas-summary-control-panel-updater commondat tabdat)
(dboard:areas-summary-xor-labels-updater commondat tabdat)
(dboard:areas-summary-buttons-updater tabdat))
(define (dboard:areas-summary-xor-labels-updater commondat 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))
(dbstruct (dboard:get-dbstruct commondat #f)))
(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:get-run-name-from-id dbstruct curr-run-id)
"None"))
(prev-runname (if prev-run-id
(db:get-run-name-from-id dbstruct 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" ""))))))
|
| ︙ | | | ︙ | |