| ︙ | | | ︙ | |
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
(prefix mtargs args:)
mtmod
mtver
processmod
runsmod
subrunmod
vgmod
)
|
<
>
|
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
|
(prefix mtargs args:)
mtmod
mtver
processmod
runsmod
subrunmod
vgmod
dashboard-context-menu)
(define help (conc
"Megatest Dashboard, documentation at http://www.kiatoa.com/fossils/megatest
version " megatest-version "
license GPL, Copyright (C) Matt Welland 2012-2017
Usage: dashboard [options]
|
| ︙ | | | ︙ | |
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
(for-each (lambda (var)
(display " ")(display var)
(if (get-environment-variable var)
|
>
|
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
"-repl"
"-rh5.11" ;; fix to allow running on rh5.11
"-:p" ;; ignore the built in chicken profiling switch
)
args:arg-hash
0))
(make-and-init-bigdata)
;; check for MT_* environment variables and exit if found
(if (not (args:get-arg "-test"))
(begin
(display "Checking for MT_ vars: ")
(for-each (lambda (var)
(display " ")(display var)
(if (get-environment-variable var)
|
| ︙ | | | ︙ | |
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
(configf:lookup *configdat* "dashboard" "no-detachbox")
(not (file-exists? "/etc/os-release")))
(set! iup:detachbox iup:vbox))
(if (not (common:on-homehost?))
(begin
(debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
|
|
|
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
;; first check for the switch
;;
(if (or (args:get-arg "-rh5.11")
(configf:lookup *configdat* "dashboard" "no-detachbox")
(not (file-exists? "/etc/os-release")))
(set! iup:detachbox iup:vbox))
#;(if (not (common:on-homehost?))
(begin
(debug:print 0 *default-log-port* "WARNING: Current policy requires running dashboard on homehost: " (common:get-homehost))))
;; RA => Might require revert for filters
;; create a watch dog to move changes from lt/.db/*.db to megatest.db
;;
;;;(if (file-write-access? (conc *toppath* "/megatest.db"))
|
| ︙ | | | ︙ | |
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
|
(cond
((member #\1 status-chars) ;; 1 is left mouse button
(dboard:launch-testpanel run-id test-id))
((member #\2 status-chars) ;; 2 is middle mouse button
(debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
(iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
(else
(debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
(iup:show (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
)
)) "runs-summary-click-callback"))))
|
|
|
|
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
|
(cond
((member #\1 status-chars) ;; 1 is left mouse button
(dboard:launch-testpanel run-id test-id))
((member #\2 status-chars) ;; 2 is middle mouse button
(debug:print-info 13 *default-log-port* "mmb- test-name="test-name" testpatt="testpatt)
(iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
(else
(debug:print-info 13 *default-log-port* "unhandled status in run-summary-click-cb. Doing right click action. (status is corrupted on Brandon's ubuntu host - bad/buggy iup install??" )
(iup:show (dashboard:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
)
)
)) "runs-summary-click-callback"))))
|
| ︙ | | | ︙ | |
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
|
"%"
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:context-menu run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
(if (eq? pressed 0)
(let* ((toolpath (car (argv)))
|
|
|
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
|
"%"
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:context-menu *bdat* run-id test-id target runname test-name testpatt item-test-path test-info) ;; popup-menu
#:x 'mouse
#:y 'mouse
#:modal? "NO")
;; (print "got here")
))
(if (eq? pressed 0)
(let* ((toolpath (car (argv)))
|
| ︙ | | | ︙ | |