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
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
|
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id) ;; run-id run-key origtest)
(let* ((testdat (db:get-test-data-by-id db test-id))
(run-id (if testdat (db:test-get-run_id testdat) #f))
(rundat (if testdat (db:get-run-info db run-id)))
(teststeps (if testdat (db:get-steps-for-test db test-id))))
(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
(let* ((widgets (make-hash-table)) ;; put the widgets to update in this hashtable
(logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(viewlog (lambda (x)
(if (file-exists? logfile)
(system (conc "firefox " logfile "&"))
(message-window (conc "File " logfile " not found")))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(system (conc "cd " rundir
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(self #f))
(hash-table-set! widgets "testdat" testdat)
(hash-table-set! widgets "rundat" rundat)
;; (test-set-status! db run-id test-name state status itemdat)
(set! self
(iup:dialog
#:title "testfullname"
(iup:hbox ;; Need a full height box for all the test steps
(iup:vbox
(iup:hbox
(iup:frame (iup:label "BLAH (was run-key)")))))))
(iup:show self)
)))))
;;
;; (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
;; (iup:frame #:title "Actions" #:expand "YES"
;; (iup:hbox ;; the actions box
;; (iup:button "View Log" #:action viewlog #:expand "YES")
;; (iup:button "Start Xterm" #:action xterm #:expand "YES")))
|
|
|
|
>
|
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
|
>
>
>
|
>
>
|
>
|
<
>
|
<
<
<
|
>
|
<
<
>
>
|
|
>
>
>
|
<
|
>
|
|
|
>
>
|
<
|
|
|
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
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
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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
|
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;;======================================================================
;;======================================================================
;;
;;======================================================================
(define (examine-test db test-id other-thread) ;; run-id run-key origtest)
(let* ((testdat (db:get-test-data-by-id db test-id))
(run-id (if testdat (db:test-get-run_id testdat) #f))
(keydat (if testdat (keys:get-key-val-pairs db run-id) #f))
(rundat (if testdat (db:get-run-info db run-id) #f))
(runname (if testdat (db:get-value-by-header (db:get-row rundat)
(db:get-header rundat)
"runname") #f))
(teststeps (if testdat (db:get-steps-for-test db test-id) #f))
(logfile "/this/dir/better/not/exist")
(rundir logfile)
(testfullname (if testdat (db:test-get-fullname testdat) "Gathering data ..."))
(viewlog (lambda (x)
(if (file-exists? logfile)
(system (conc "firefox " logfile "&"))
(message-window (conc "File " logfile " not found")))))
(xterm (lambda (x)
(if (directory-exists? rundir)
(let ((shell (if (get-environment-variable "SHELL")
(conc "-e " (get-environment-variable "SHELL"))
"")))
(system (conc "cd " rundir
";xterm -T \"" (string-translate testfullname "()" " ") "\" " shell "&")))
(message-window (conc "Directory " rundir " not found")))))
(refreshdat (lambda ()
(set! testdat (db:get-test-data-by-id db test-id))
(set! teststeps (db:get-steps-for-test db test-id))
(set! logfile (conc (db:test-get-rundir testdat) "/" (db:test-get-final_logf testdat)))
(set! rundir (db:test-get-rundir testdat))
(set! testfullname (db:test-get-fullname testdat))))
(widgets (make-hash-table))
(self #f)
(store-label (lambda (name lbl cmd)
(hash-table-set! widgets name (lambda ()
(iup:attribute-set! lbl "TITLE" (cmd))))
lbl))
(store-button (lambda (name btn cmd)
(hash-table-set! widgets name (lambda (cmd)
(iup:attribute-set! btn "TITLE" (cmd))))
btn))
)
(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
(iup:dialog
#:title testfullname
(iup:hbox #:expand "BOTH" ;; Need a full height box for all the test steps
(iup:vbox #:expand "BOTH"
(iup:hbox #:expand "BOTH"
(iup:frame #:title "Run Info" #:expand "VERTICAL"
(iup:hbox #:expand "BOTH"
(apply iup:vbox #:expand "BOTH"
(append (map (lambda (keyval)
(iup:label (conc (car keyval) " ") #:expand "HORIZONTAL"))
keydat)
(list (iup:label "runname "))))
(apply iup:vbox
(append (map (lambda (keyval)
(iup:label (cadr keyval) #:expand "HORIZONTAL"))
keydat)
(list (iup:label runname))))))
(iup:frame #:title "Test Info" #:expand "VERTICAL"
(iup:hbox #:expand "BOTH"
(apply iup:vbox #:expand "BOTH"
(map (lambda (val)
(iup:label val #:expand "HORIZONTAL"))
(list "Testname: "
"Item path: "
"Current state: "
"Current status: "
"Test comment: ")))
(apply iup:vbox #:expand "BOTH"
(list
(iup:label (db:test-get-testname testdat) #:expand "BOTH")
(iup:label (db:test-get-item-path testdat) #:expand "BOTH")
(store-label "teststate"
(iup:label "TestState" #:expand "BOTH")
(lambda ()
(db:test-get-state testdat)))
(store-label "teststatus"
(iup:label "TestStatus" #:expand "BOTH")
(lambda ()
(db:test-get-status testdat)))
(store-label "testcomment"
(iup:label "TestComment" #:expand "BOTH")
(lambda ()
(db:test-get-comment testdat))))))))))))
(iup:show self)
;; Now start keeping the gui updated from the db
(let loop ((i 0))
(thread-sleep! 0.1)
(refreshdat) ;; update from the db here
(thread-suspend! other-thread)
;; update the gui elements here
(for-each
(lambda (key)
(print "Updating " key)
((hash-table-ref widgets key)))
(hash-table-keys widgets))
(thread-resume! other-thread)
(loop i))))))
;;
;; (iup:frame (iup:label (conc "TESTNAME:\n" testfullname) #:expand "YES")))
;; (iup:frame #:title "Actions" #:expand "YES"
;; (iup:hbox ;; the actions box
;; (iup:button "View Log" #:action viewlog #:expand "YES")
;; (iup:button "Start Xterm" #:action xterm #:expand "YES")))
|