27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
(declare (uses db))
(declare (uses gutils))
(declare (uses ezsteps))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(define (test-info-panel testdat store-label widgets)
(iup:frame
#:title "Test Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
(apply iup:vbox ; #:expand "YES"
(append (map (lambda (val)
|
>
>
>
>
>
>
>
>
>
>
>
>
>
|
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
|
(declare (uses db))
(declare (uses gutils))
(declare (uses ezsteps))
(include "common_records.scm")
(include "db_records.scm")
(include "run_records.scm")
;;======================================================================
;; C O M M O N
;;======================================================================
(define (dtests:get-pre-command #!key (default-override #f))
(let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "pre-command")))
(or cfg-ovrd default-override "xterm -geometry 180x20 -e \"")))
(define (dtests:get-post-command #!key (default-override #f))
(let ((cfg-ovrd (configf:lookup *configdat* "dashboard" "post-command")))
(or cfg-ovrd default-override ";echo Press any key to continue;bash -c 'read -n 1 -s'\" &")))
(define (test-info-panel testdat store-label widgets)
(iup:frame
#:title "Test Info" ; #:expand "YES"
(iup:hbox ; #:expand "YES"
(apply iup:vbox ; #:expand "YES"
(append (map (lambda (val)
|
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
|
(iup:attribute-set! lbl "TITLE" newval)
;(mutex-unlock! mx1)
)))))
lbl))
(store-button store-label)
(command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(let ((cmd (iup:attribute command-text-box "VALUE")))
(system (conc cmd " &"))))))
(kill-jobs (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "xterm -geometry 180x20 -e \"megatest -target " keystring " -runname " runname
" -set-state-status KILLREQ,n/a -testpatt %/% "
;; (conc testname "/" (if (equal? item-path "") "%" item-path))
" -state RUNNING ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
(conc "xterm -geometry 180x20 -e \"megatest -target " keystring " -runname " runname
" -runtests " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))))
(clean-run-execute (lambda (x)
(let ((cmd (conc "xterm -geometry 180x20 -e \""
"megatest -remove-runs -target " keystring " -runname " runname
" ;echo Press any key to continue;bash -c 'read -n 1 -s'\"")))
(system (conc cmd " &")))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "xterm -geometry 180x20 -e \"megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v ;echo Press any key to continue;bash -c 'read -n 1 -s'\""))
)))
(cond
((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
(else
;; (test-set-status! db run-id test-name state status itemdat)
(set! self ;
|
|
>
>
>
>
|
|
<
|
|
|
|
|
<
|
|
|
|
|
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
|
(iup:attribute-set! lbl "TITLE" newval)
;(mutex-unlock! mx1)
)))))
lbl))
(store-button store-label)
(command-text-box (iup:textbox #:expand "HORIZONTAL" #:font "Courier New, -10"))
(command-launch-button (iup:button "Execute!" #:action (lambda (x)
(let* ((cmd (iup:attribute command-text-box "VALUE"))
(fullcmd (conc (dtests:get-pre-command)
cmd
(dtests:get-post-command))))
(debug:print-info 0 "Running command: " fullcmd)
(system fullcmd)))))
(kill-jobs (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -set-state-status KILLREQ,n/a -testpatt %/% "
" -state RUNNING"))))
(run-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -target " keystring " -runname " runname
" -runtests " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v"))))
(clean-run-execute (lambda (x)
(let ((cmd (conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
";megatest -target " keystring " -runname " runname
" -runtests " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
)))
(system (conc cmd " &")))))
(remove-test (lambda (x)
(iup:attribute-set!
command-text-box "VALUE"
(conc "megatest -remove-runs -target " keystring " -runname " runname
" -testpatt " (conc testname "/" (if (equal? item-path "")
"%"
item-path))
" -v"))
)))
(cond
((not testdat)(begin (print "ERROR: bad test info for " test-id)(exit 1)))
((not rundat)(begin (print "ERROR: found test info but there is a problem with the run info for " run-id)(exit 1)))
(else
;; (test-set-status! db run-id test-name state status itemdat)
(set! self ;
|