127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
(open-run-close set-run-config-vars #f run-id keys keyvals)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(set-megatest-env-vars run-id)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
(open-run-close test-set-meta-info #f test-id run-id test-name itemdat 0)
(tests:test-set-status! 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
|
>
|
|
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
(open-run-close set-run-config-vars #f run-id keys keyvals)
;; environment overrides are done *before* the remaining critical envars.
(alist->env-vars env-ovrd)
(set-megatest-env-vars run-id)
(set-item-env-vars itemdat)
(save-environment-as-files "megatest")
;; open-run-close not needed for test-set-meta-info
(test-set-meta-info #f test-id run-id test-name itemdat 0)
(tests:test-set-status! 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
|
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
|
;; (if (and prevstep (file-exists? prev-env))
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
(cdb:remote-run db:teststep-set-status! #f test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
(mutex-unlock! m)
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(cdb:remote-run db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna))
(if logpro-used
(cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
|
|
|
|
|
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
|
;; (if (and prevstep (file-exists? prev-env))
;; (set! script (conc script "source " prev-env))))
;; call the command using mt_ezstep
(set! script (conc "mt_ezstep " stepname " " (if prevstep prevstep "-") " " stepcmd))
(debug:print 4 "script: " script)
;; DO NOT remote
(db:teststep-set-status! #f test-id stepname "start" "-" #f #f)
;; now launch
(let ((pid (process-run script)))
(let processloop ((i 0))
(let-values (((pid-val exit-status exit-code)(process-wait pid #t)))
(mutex-lock! m)
(vector-set! exit-info 0 pid)
(vector-set! exit-info 1 exit-status)
(vector-set! exit-info 2 exit-code)
(mutex-unlock! m)
(if (eq? pid-val 0)
(begin
(thread-sleep! 2)
(processloop (+ i 1))))
))
(let ((exinfo (vector-ref exit-info 2))
(logfna (if logpro-used (conc stepname ".html") "")))
;; testing if procedures called in a remote call cause problems (ans: no or so I suspect)
(db:teststep-set-status! #f test-id stepname "end" exinfo #f logfna))
(if logpro-used
(cdb:test-set-log! *runremote* test-id (conc stepname ".html")))
;; set the test final status
(let* ((this-step-status (cond
((and (eq? (vector-ref exit-info 2) 2) logpro-used) 'warn)
((eq? (vector-ref exit-info 2) 0) 'pass)
(else 'fail)))
|
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
|
(-
(current-seconds)
start-seconds)))))
(kill-tries 0))
(let loop ((minutes (calc-minutes)))
(begin
(set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat))
(open-run-close test-set-meta-info #f test-id run-id test-name itemdat minutes)
(if kill-job?
(begin
(mutex-lock! m)
(let* ((pid (vector-ref exit-info 0)))
(if (number? pid)
(begin
(debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
|
>
|
|
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
|
(-
(current-seconds)
start-seconds)))))
(kill-tries 0))
(let loop ((minutes (calc-minutes)))
(begin
(set! kill-job? (test-get-kill-request test-id)) ;; run-id test-name itemdat))
;; open-run-close not needed for test-set-meta-info
(test-set-meta-info #f test-id run-id test-name itemdat minutes)
(if kill-job?
(begin
(mutex-lock! m)
(let* ((pid (vector-ref exit-info 0)))
(if (number? pid)
(begin
(debug:print 0 "WARNING: Request received to kill job (attempt # " kill-tries ")")
|