1
2
3
4
5
6
7
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
|
1
2
3
4
5
6
7
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
|
-
+
+
-
+
-
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
;; Copyright 2006-2016, Matthew Welland.
;;
;; This program is made available under the GNU GPL version 2.0 or
;; greater. See the accompanying file COPYING for details.
;;
;; This program is distributed WITHOUT ANY WARRANTY; without even the
;; implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE.
;; strftime('%m/%d/%Y %H:%M:%S','now','localtime')
(use (prefix sqlite3 sqlite3:) srfi-1 posix regex regex-case srfi-69 (srfi 18)
posix-extras directory-utils pathname-expand typed-records format)
posix-extras directory-utils pathname-expand typed-records format
call-with-environment-variables)
(declare (unit subrun))
;;(declare (uses runs))
;;(declare (uses db))
;;(declare (uses mt))
;;(include "db_records.scm")
|
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
|
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
-
-
+
+
-
-
-
-
-
-
-
-
-
+
+
-
-
+
-
-
-
+
-
-
-
-
+
+
+
+
-
|
(define (subrun:remove-subrun test-run-dir new-test-dat test-name item-path test-state test-fulln toplevel-with-children test)
;; set state/status of test item
;; fork off megatest
;; set state/status of test item
;;
(let* ((subrun-alist (subrun:selector+log-alist test-run-dir log-prefix))
(BB> "Entered subrun:remove-subrun with "test-fulln)
(if (and (not (subrun:subrun-removed? test-run-dir)) (subrun:subrun-test-initialized? test-run-dir))
(runlog (alist-ref "-log" subrun-alist equal? #f)))
(if (not (common:file-exists? runlog))
(BB> "no runlog @ "runlog)
(if (member test-state (list "RUNNING" "LAUNCHED" "REMOTEHOSTSTART" "KILLREQ"))
;; This test is not in a correct state for cleaning up. Let's try some graceful shutdown steps first
;; Set the test to "KILLREQ" and wait five seconds then try again. Repeat up to five times then give
;; up and blow it away.
;; call in submegatest:
;; (tasks:kill-runner target run-name testpatt)
(mt:test-set-state-status-by-id run-id (db:test-get-id test) "SUBRUN-KILLREQ" "n/a" #f)
)
;; on success:
;; set state of test, or delete it or whatever
)
)
)
|
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
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
|
-
+
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(map
(lambda (x)
(list (car x) (cdr x)))
switch-alist))
" ")))
res))
(define (subrun:exec-sub-megatest test-run-dir switches #!key (logfile #f))
(define (subrun:exec-sub-megatest test-run-dir action-switches-str log-prefix)
(let* ((real-logfile (or logfile (conc (test-run-dir) "/subrun-"
(string-substitute "[/*]" "_" (string-intersperse switches "^"))"-"
(number->string (current-seconds)) ".log")))
(selector-switches (common:sub-megatest-selector-switches test-run-dir))
(cmd-list `("megatest" ,@selector-switches ,@switches "-log" ,real-logfile))
)
(common:without-vars proc "^MT_.*")
))))
(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")
|