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
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
|
call-with-environment-variables)
(import commonmod
configfmod
debugprint
tasksmod)
;(include "common_records.scm")
;;(include "key_records.scm")
(include "db_records.scm") ;; provides db:test-get-id
;;(include "run_records.scm")
;;(include "test_records.scm")
(define (subrun:subrun-test-initialized? test-run-dir)
(if (and (common:file-exists? (conc test-run-dir "/subrun-area") )
(common:file-exists? (conc test-run-dir "/testconfig.subrun") ))
#t
#f))
(define (subrun:launch-dashboard test-run-dir)
(if (subrun:subrun-test-initialized? test-run-dir)
(let* ((subarea (subrun:get-runarea test-run-dir)))
(if (and subarea (common:file-exists? subarea))
(system (conc "cd " subarea ";env -i PATH=\"$PATH\" DISPLAY=$DISPLAY HOME=$HOME USER=$USER dashboard &"))))))
(define (subrun:subrun-removed? test-run-dir)
(if (subrun:subrun-test-initialized? test-run-dir)
(let ((flagfile (conc test-run-dir "/subrun.removed")))
(if (common:file-exists? flagfile)
#t
#f))
#t))
(define (subrun:set-subrun-removed test-run-dir)
(let ((flagfile (conc test-run-dir "/subrun.removed")))
(if (and (subrun:subrun-test-initialized? test-run-dir) (not (common:file-exists? flagfile)))
(with-output-to-file flagfile
(lambda () (print (current-seconds)))))))
(define (subrun:unset-subrun-removed test-run-dir)
(let ((flagfile (conc test-run-dir "/subrun.removed")))
(if (and (subrun:subrun-test-initialized? test-run-dir) (common:file-exists? flagfile))
(delete-file flagfile))))
(define (subrun:testconfig-defines-subrun? testconfig)
(configf:lookup testconfig "subrun" "runwait")) ;; we use runwait as the flag that a subrun is requested
(define (subrun:initialize-toprun-test testconfig test-run-dir)
(let ((ra (configf:lookup testconfig "subrun" "run-area"))
(logpro (configf:lookup testconfig "subrun" "logpro"))
(symlink-target (conc test-run-dir "/subrun-area"))
)
(if (not ra) ;; when runarea is not set we default to *toppath*. However
(let ((fallback-run-area (or *toppath* (conc test-run-dir "/subrun"))))
;; we need to force the setting in the testconfig so it will
;; be preserved in the testconfig.subrun file
(configf:set-section-var testconfig "subrun" "run-area" fallback-run-area)
(set! ra fallback-run-area)))
(configf:set-section-var testconfig "logpro" "subrun" logpro) ;; append the logpro rules to the logpro section as stepname subrun
(if (common:file-exists? symlink-target)
(delete-file symlink-target))
(create-symbolic-link ra symlink-target)
(configf:write-alist testconfig "testconfig.subrun")))
(define (subrun:set-state-status test-run-dir state status new-state-status)
(if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
(let* ((action-switches-str
(conc "-set-state-status "new-state-status
(if state (conc " -state "state) "")
(if status (conc " -status "status) "")))
(log-prefix
(subrun:sanitize-path
(conc "set-state-status="new-state-status
(if state (conc ":state="state) "")
(if status (conc "+status="status) ""))))
(submt-result
(subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)))
submt-result)))
(define (subrun:remove-subrun test-run-dir keep-records )
(if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
(let* ((action-switches-str
(conc "-remove-runs"
(if keep-records "-keep-records " "")
))
(remove-result
(subrun:exec-sub-megatest test-run-dir action-switches-str "remove")))
(if remove-result
(begin
(subrun:set-subrun-removed test-run-dir)
#t)
#f))
#t))
(define (subrun:kill-subrun test-run-dir )
(if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
(let* ((action-switches-str
(conc "-kill-runs" ))
(kill-result
(subrun:exec-sub-megatest test-run-dir action-switches-str "kill")))
kill-result)
#t))
(define (subrun:launch-cmd test-run-dir run-mode #!optional (sub-cmd "-run")) ;; BUG: "-run" should be changed to "-rerun-clean" but current doesn't work
(if (subrun:subrun-removed? test-run-dir)
(subrun:unset-subrun-removed test-run-dir))
(let* ((log-prefix "run")
(switches (subrun:selector+log-switches test-run-dir log-prefix))
(run-wait (equal? run-mode "yes"))
(cmd (conc (common:get-mtexe)" "sub-cmd" "switches" "
(if run-wait "-run-wait " ""))))
cmd))
(define (subrun:sanitize-path inpath)
(let* ((insane-pattern (irregex "[^[a-zA-Z0-9_\\-]")))
(regex#string-substitute insane-pattern "_" inpath #t)))
(define (subrun:get-runarea test-run-dir)
(if (subrun:subrun-test-initialized? test-run-dir)
(let* ((info-alist (subrun:selector+log-alist
test-run-dir
"foo"))
(run-area (if (list? info-alist)
(alist-ref "-start-dir" info-alist equal? #f)
#f)))
run-area)
#f))
(define (subrun:selector+log-alist test-run-dir log-prefix)
(let* ((switch-def-alist (common:get-param-mapping flavor: 'config))
(subrunfile (conc test-run-dir "/testconfig.subrun" ))
(subrundata (with-input-from-file subrunfile read))
(subrunconfig (configf:alist->config subrundata))
(run-area (configf:lookup subrunconfig "subrun" "run-area"))
(defvals `(("start-dir" . ,(or run-area ;; default values if not specified in subrun section of tconf
(get-environment-variable "MT_RUN_AREA_HOME")
"/no/rundir/found"))
("run-name" . ,(or (get-environment-variable "MT_RUNNAME") "NO-RUNNAME"))
("target" . ,(or (get-environment-variable "MT_TARGET") "NO-TARGET"))))
(switch-alist-pre (filter-map (lambda (item)
(let* ((config-key (car item))
(switch (cdr item))
(defval (alist-ref config-key defvals equal? #f))
(val (or (configf:lookup subrunconfig "subrun" config-key)
defval)))
(if val
(cons switch val)
#f)))
switch-def-alist))
;; testpatt may be modified if all three of mode-patt, tag-expr, and testpatt are null
(mode-patt (alist-ref "-modepatt" switch-alist-pre equal? #f))
(tag-expr (alist-ref "-tagexpr" switch-alist-pre equal? #f))
(testpatt (alist-ref "-testpatt" switch-alist-pre equal?
(if (not (or mode-patt tag-expr)) "%" #f))) ;; testpatt is % if not
;; otherwise specified
;; define compact-stem for logfile
(target (alist-ref "-target" switch-alist-pre equal? #f)) ;; want data-structures alist-ref, not alist-lib alist-ref
(runname (alist-ref "-runname" switch-alist-pre equal? #f))
(compact-stem (subrun:sanitize-path
(conc
target
"-"
runname
"-" (or testpatt mode-patt tag-expr "NO-TESTPATT"))))
(logfile (conc
test-run-dir "/"
(if log-prefix
(conc (subrun:sanitize-path log-prefix) "-")
"")
compact-stem
".log"))
;; swap out testpatt with modified test-patt and add -log
(switch-alist (cons
(cons "-log" logfile)
(map (lambda (item)
(if (equal? (car item) "-testpatt")
(cons "-testpatt" testpatt)
item))
switch-alist-pre))))
switch-alist))
;; note - get precmd from subrun section
;; apply to submegatest commands
(define (subrun:get-log-path test-run-dir log-prefix)
(let* ((alist (subrun:selector+log-alist test-run-dir log-prefix))
(res (alist-ref "-log" alist equal? #f)))
res))
(define (subrun:selector+log-switches test-run-dir log-prefix)
(let* ((switch-alist (subrun:selector+log-alist test-run-dir log-prefix))
(res
(string-intersperse
(apply
append
(map
(lambda (x)
(list (car x) (cdr x)))
switch-alist))
" ")))
res))
;; NOTE: Here we run sub megatest but this is not intended for one version
;; of megatest to test another version. Thus we propagate the
(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)
(let* ((mtpathdir (common:get-megatest-exe-dir))
(mtexe (common:get-mtexe))
(selector-switches (subrun:selector+log-switches test-run-dir log-prefix))
(cmd (conc mtexe" "selector-switches" "action-switches-str ))
(pid #f)
(proc (lambda ()
(debug:print-info 0 *default-log-port* "Running sub megatest command: "cmd)
;;(set! pid (process-run "/usr/bin/xterm" (list ))))))
(set! pid (process-run "/bin/bash" (list "-c" cmd))))))
(call-with-environment-variables
(list (cons "PATH" (common:get-megatest-exe-path)))
(lambda ()
(common:without-vars proc "^MT_.*")))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1)))
(begin
(debug:print-info 0 *default-log-port* "sub megatest " action-switches-str " completed with exit code " exit-code)
(if (eq? 0 exit-code)
(begin
#t)
(begin
#f))))))))
;; (subrun:exec-sub-megatest "/nfs/pdx/disks/icf_env_disk001/bjbarcla/gwa/issues/mtdev/165/megatest/ext-tests/tests/subrun-usecases/toparea/links/SYSTEM_val/RELEASE_val/go/toptest" "-foo" "foo")
|
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
|
34
35
36
37
38
39
40
|
call-with-environment-variables)
(import commonmod
configfmod
debugprint
tasksmod)
|