| ︙ | | | ︙ | |
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
;;======================================================================
;;======================================================================
;; Test info panel
;;======================================================================
(import format fmt)
(import (prefix iup iup:))
(import canvas-draw)
(import srfi-1
chicken.file.posix
regex regex-case srfi-69
(prefix sqlite3 sqlite3:))
(include "db_records.scm")
(include "run_records.scm")
(import
commonmod
dbmod
rmtmod
ezstepsmod
subrunmod
debugprint
)
|
<
<
<
<
<
<
<
<
<
<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
>
>
>
>
>
|
>
|
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
|
;;======================================================================
;;======================================================================
;; Test info panel
;;======================================================================
(declare (unit dashboard-tests))
(declare (uses commonmod))
(declare (uses dbmod))
(declare (uses gutils))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrunmod))
(declare (uses debugprint))
(declare (uses configfmod))
(declare (uses testsmod))
(declare (uses mtmod))
(declare (uses dcommon))
(declare (uses launchmod))
(module dashboard-tests
*
(import scheme
chicken.file.posix
chicken.base
chicken.string
chicken.condition
chicken.file
chicken.process-context
chicken.time
format
fmt
(prefix iup iup:)
canvas-draw
srfi-1
srfi-18
regex regex-case srfi-69
(prefix sqlite3 sqlite3:))
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
(import commonmod
dcommon
dbmod
rmtmod
ezstepsmod
subrunmod
debugprint
gutils
configfmod
testsmod
mtmod
launchmod
)
;;======================================================================
;; C O M M O N
;;======================================================================
(define *tim* (iup:timer))
(define *dashboard-comment-share-slot* #f)
(define (message-window msg)
(iup:show
(iup:dialog
(iup:vbox
|
| ︙ | | | ︙ | |
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
|
dlog))
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
(let* ((db-path (db:dbfile-path)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
(dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (db:dbfile-path #f) ;; (configf:lookup *configdat* "setup" "linktree")
;; local: #t))
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
(begin
|
|
|
|
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
|
dlog))
;;======================================================================
;;
;;======================================================================
(define (dashboard-tests:examine-test run-id test-id) ;; run-id run-key origtest)
(let* ((db-path (common:get-db-tmp-area)) ;; (conc (configf:lookup *configdat* "setup" "linktree") "/db/" run-id ".db"))
(dbstruct #f) ;; NOT ACTUALLY USED (db:setup)) ;; (make-dbr:dbstruct path: (common:get-db-tmp-area #f) ;; (configf:lookup *configdat* "setup" "linktree")
;; local: #t))
(testdat (rmt:get-test-info-by-id run-id test-id)) ;; (db:get-test-info-by-id dbstruct run-id test-id))
(db-mod-time 0) ;; (file-modification-time db-path))
(last-update 0) ;; (current-seconds))
(request-update #t))
(if (not testdat)
(begin
|
| ︙ | | | ︙ | |
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
|
(dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
))
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;; additional setters for dboard:data
(define (dboard:tabdat-test-patts-set!-use vec val)
(dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
(let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
(cmd (dboard:tabdat-command tabdat))
(test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
|
|
|
|
|
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
|
(dcommon:initial-draw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
(dcommon:redraw-tests cnv xadj yadj sizex sizey sizexmm sizeymm originx originy tests-draw-state sorted-testnames test-records))
))
(define (dboard:tabdat-test-patts-use vec)
(let ((val (dboard:tabdat-test-patts vec)))(if val val ""))) ;;RADT => What is the if for?
;; ;; additional setters for dboard:data
;; (define (dboard:tabdat-test-patts-set!-use vec val)
;; (dboard:tabdat-test-patts-set! vec (if (equal? val "") #f val)))
;; Extract the various bits of data from tabdat and create the command line equivalent that will be displayed
;;
(define (dashboard:update-run-command tabdat)
(let* ((cmd-tb (dboard:tabdat-command-tb tabdat))
(cmd (dboard:tabdat-command tabdat))
(test-patt (let ((tp (dboard:tabdat-test-patts tabdat)))
|
| ︙ | | | ︙ | |
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
|
(if (equal? selected-item item)
(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
(set! i (+ i 1)))
items)
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
;; if tab-num passed in then use it, otherwise look in commondat at curr-tab-num
;; adds the updater passed in the updaters list at that hashkey
;;
(define (dboard:commondat-add-updater commondat updater #!key (tab-num #f))
(let* ((tnum (or tab-num
(dboard:commondat-curr-tab-num commondat)))
(curr-updaters (hash-table-ref/default (dboard:commondat-updaters commondat) tnum '())))
(hash-table-set! (dboard:commondat-updaters commondat)
tnum
(cons updater curr-updaters))))
|
<
<
<
<
<
<
<
<
<
<
|
|
963
964
965
966
967
968
969
970
|
(if (equal? selected-item item)
(iup:attribute-set! lb "VALUE" i))) ;; (number->string i))))
(set! i (+ i 1)))
items)
;; (iup:attribute-set! lb "VALUE" (if selected-item selected-item ""))
i))
)
|