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
|
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
|
+
+
+
-
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
+
-
-
+
+
+
-
-
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
+
+
+
|
;;======================================================================
;;======================================================================
;; implementation of context menu that pops up on
;; right click on test cell in Runs & Runs Summary Tabs
;;======================================================================
(module dashboard-context-menu
*
(use format fmt)
(import format fmt)
(require-library iup)
(use canvas-draw)
(import canvas-draw)
(import scheme
srfi-1
chicken.base
chicken.condition
chicken.port
chicken.file.posix
chicken.pathname
chicken.process
chicken.process-context
chicken.string
chicken.time
srfi-1
(use srfi-1 posix regex regex-case srfi-69)
(use (prefix sqlite3 sqlite3:))
(declare (uses common))
(declare (uses db))
(declare (uses commonmod))
(declare (uses configfmod))
(declare (uses dbmod))
(declare (uses gutils))
(declare (uses rmt))
(declare (uses ezsteps))
(declare (uses rmtmod))
(declare (uses ezstepsmod))
;; (declare (uses sdb))
;; (declare (uses filedb))
(declare (uses subrun))
(declare (uses subrunmod))
(declare (uses debugprint))
(declare (uses testsmod))
(declare (uses dcommon))
(import commonmod
dbmod
rmtmod
ezstepsmod
subrunmod
debugprint
configfmod
testsmod
dcommon
)
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;; (include "common_records.scm")
;; (include "db_records.scm")
;; (include "run_records.scm")
(define (dboard:launch-testpanel run-id test-id)
(let* ((dboardexe (common:find-local-megatest "dashboard"))
(cmd (conc dboardexe
" -test " run-id "," test-id
" &")))
(system cmd)))
|
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
|
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
|
-
+
+
-
+
|
;; item5 custom show test-patt (%test-patt%):echo "%test-patt%"
;; item6 custom show test-run-dir (%test-run-dir%):echo "%test-run-dir%"
;; item7 custom show run-area-home (%run-area-home%):echo "%run-area-home%"
;; item8 custom show megatest root (%mt-root%):echo "%mt-root%"
;; item9 custom ls : ls -lrt
;; item10 custom see $MT_RUN_AREA_HOME (not yet implemented) : echo $MT_RUN_AREA_HOME
(define (dashboard:custom-menu-items run-id test-id target run-name test-name testpatt item-test-path test-info)
(define (dashboard:custom-menu-items bdat run-id test-id target run-name test-name testpatt item-test-path test-info)
(let* ((vars (configf:section-vars *configdat* "custom-context-menu-items"))
(item-path (db:test-get-item-path test-info))
;; (bdat-this-exe-dir-set! bdat (pathname-directory fullp))
(mt-root (pathname-directory (pathname-directory *common:this-exe-dir* ))))
(mt-root (pathname-directory (pathname-directory (bdat-this-exe-dir bdat)))))
(filter-map
(lambda (var)
(let* ((val (configf:lookup *configdat* "custom-context-menu-items" var))
(m (string-match "^\\s*([^:]+?)\\s*:\\s*(.*?)\\s*$" val)))
(if m
(let* ((menu-item-text-raw (list-ref m 1))
(command-line-raw (list-ref m 2))
|
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
|
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
|
-
+
-
+
+
+
|
(begin
;;(BB> "gonna eval it!")
(eval (with-input-from-string (cadr scheme-match) read)))))
(common:run-a-command command-line with-vars: #t))))))))
#f)))
vars)))
(define (dashboard:context-menu run-id test-id target runname test-name testpatt item-test-path test-info)
(define (dashboard:context-menu bdat run-id test-id target runname test-name testpatt item-test-path test-info)
(let* ((run-menu-items
(dashboard:run-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
(test-menu-items
(dashboard:test-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
(custom-menu-items
(dashboard:custom-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
(dashboard:custom-menu-items bdat run-id test-id target runname test-name testpatt item-test-path test-info))
(toplevel-menu-items
(dashboard:toplevel-menu-items run-id test-id target runname test-name testpatt item-test-path test-info))
)
(apply iup:menu
`(,@toplevel-menu-items
,(iup:menu-item
"Run"
(apply iup:menu run-menu-items))
,(iup:menu-item
"Test"
(apply iup:menu test-menu-items))
,@custom-menu-items))))
)
|