| ︙ | | |
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
|
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
|
-
+
-
-
+
-
+
|
(change-directory top-path)
(if (not (setup-for-run))
(begin
(debug:print 0 "Failed to setup, exiting")
;; (sqlite3:finalize! db)
;; (sqlite3:finalize! tdb)
(exit 1)))
(change-directory *toppath*)
(change-directory *toppath*)
(open-run-close test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(open-run-close tests:test-set-status! #f test-id "REMOTEHOSTSTART" "n/a" (args:get-arg "-m") #f)
(if (args:get-arg "-xterm")
(set! fullrunscript "xterm")
(if (and fullrunscript (not (file-execute-access? fullrunscript)))
(system (conc "chmod ug+x " fullrunscript))))
;; We are about to actually kick off the test
;; so this is a good place to remove the records for
;; any previous runs
;; (db:test-remove-steps db run-id testname itemdat)
(let* ((m (make-mutex))
(kill-job? #f)
(exit-info (vector #t #t #t))
(job-thread #f)
(runit (lambda ()
;; (let-values
;; (((pid exit-status exit-code)
;; (run-n-wait fullrunscript)))
(open-run-close test-set-status! #f test-id "RUNNING" "n/a" #f #f)
(open-run-close tests:test-set-status! #f test-id "RUNNING" "n/a" #f #f)
;; if there is a runscript do it first
(if fullrunscript
(let ((pid (process-run fullrunscript)))
(let loop ((i 0))
(let-values
(((pid-val exit-status exit-code) (process-wait pid #t)))
(mutex-lock! m)
|
| ︙ | | |
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
|
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
-
+
-
+
-
+
|
(debug:print 4 "Exit value received: " (vector-ref exit-info 2) " logpro-used: " logpro-used
" this-step-status: " this-step-status " overall-status: " overall-status
" next-status: " next-status " rollup-status: " rollup-status)
(case next-status
((warn)
(set! rollup-status 2)
;; NB// test-set-status! does rdb calls under the hood
(open-run-close test-set-status! #f test-id "RUNNING" "WARN"
(open-run-close tests:test-set-status! #f test-id "RUNNING" "WARN"
(if (eq? this-step-status 'warn) "Logpro warning found" #f)
#f))
((pass)
(open-run-close test-set-status! #f test-id "RUNNING" "PASS" #f #f))
(open-run-close tests:test-set-status! #f test-id "RUNNING" "PASS" #f #f))
(else ;; 'fail
(set! rollup-status 1) ;; force fail
(open-run-close test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
(open-run-close tests:test-set-status! #f test-id "RUNNING" "FAIL" (conc "Failed at step " stepname) #f)
))))
(if (and (steprun-good? logpro-used (vector-ref exit-info 2))
(not (null? tal)))
(loop (car tal) (cdr tal) stepname)))
(debug:print 4 "WARNING: a prior step failed, stopping at " ezstep))))))))
(monitorjob (lambda ()
(let* ((start-seconds (current-seconds))
|
| ︙ | | |
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
|
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
|
-
+
|
(begin
(debug:print 0 "Killing " (cadr parts) "; kill -9 " p-id)
(system (conc "kill -9 " p-id))))))
(car processes))
(system (conc "kill -9 " pid))))
(begin
(debug:print 0 "WARNING: Request received to kill job but problem with process, attempting to kill manager process")
(open-run-close test-set-status! #f test-id "KILLED" "FAIL"
(open-run-close tests:test-set-status! #f test-id "KILLED" "FAIL"
(args:get-arg "-m") #f)
(sqlite3:finalize! tdb)
(exit 1))))
(set! kill-tries (+ 1 kill-tries))
(mutex-unlock! m)))
;; (sqlite3:finalize! db)
(thread-sleep! (+ 10 (random 10))) ;; add some jitter to the call home time to spread out the db accesses
|
| ︙ | | |
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
|
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
|
-
+
|
;; (if (not (args:get-arg "-server"))
;; (server:client-setup db))
(let* ((item-path (item-list->path itemdat))
(testinfo (open-run-close db:get-test-info-by-id #f test-id))) ;; )) ;; run-id test-name item-path)))
(if (not (equal? (db:test-get-state testinfo) "COMPLETED"))
(begin
(debug:print 2 "Test NOT logged as COMPLETED, (state=" (db:test-get-state testinfo) "), updating result, rollup-status is " rollup-status)
(open-run-close test-set-status! #f test-id
(open-run-close tests:test-set-status! #f test-id
(if kill-job? "KILLED" "COMPLETED")
;; Old logic:
;; (if (vector-ref exit-info 1) ;; look at the exit-status, #t means it at least ran
;; (if (and (not kill-job?)
;; (eq? (vector-ref exit-info 2) 0)) ;; we can now use rollup-status instead
;; "PASS"
;; "FAIL")
|
| ︙ | | |
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
|
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
|
-
+
|
(list 'set-vars (if params (hash-table-ref/default params "-setvars" #f)))
(list 'runname runname)
(list 'mt-bindir-path mt-bindir-path))))))) ;; (string-intersperse keyvallst " "))))
;; clean out step records from previous run if they exist
(debug:print 4 "INFO: FIXMEEEEE!!!! This can be removed some day, perhaps move all test records to the test db?")
(open-run-close db:delete-test-step-records db test-id)
(change-directory work-area) ;; so that log files from the launch process don't clutter the test dir
(open-run-close test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(open-run-close tests:test-set-status! db test-id "LAUNCHED" "n/a" #f #f) ;; (if launch-results launch-results "FAILED"))
(cond
((and launcher hosts) ;; must be using ssh hostname
(set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (car hosts)(list remote-megatest test-sig "-execute" cmdparms))))
(launcher
(set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms) debug-param)))
;; (set! fullcmd (append launcher (list remote-megatest test-sig "-execute" cmdparms))))
|
| ︙ | | |