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
|
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
|
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
(event-time (db:test-get-event_time test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat)))
(target (getenv "MT_TARGET"))
(runname (getenv "MT_RUNNAME")))
;; (mutex-lock! *triggers-mutex*)
(handle-exceptions
exn
(begin
(debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
"\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
"\n test-rundir="test-rundir
"\n test-name="test-name
"\n item-path="item-path
"\n state="state
"\n status="status
"\n")
(print-call-chain (current-error-port))
#f)
;;;;;; (handle-exceptions
;;;;;; exn
;;;;;; (begin
;;;;;; (debug:print-error 0 *default-log-port* " Exception in mt:process-triggers for run-id="run-id" test-id="test-id" newstate="newstate" newstatus="newstatus
;;;;;; "\n error: " ((condition-property-accessor 'exn 'message) exn) ", exn=" exn
;;;;;; "\n test-rundir="test-rundir
;;;;;; "\n test-name="test-name
;;;;;; "\n item-path="item-path
;;;;;; "\n state="state
;;;;;; "\n status="status
;;;;;; "\n")
;;;;;; (print-call-chain (current-error-port))
;;;;;; (with-output-to-port *default-log-port*
;;;;;; (lambda ()
;;;;;; (print (condition->list exn))))
;;;;;; #f)
(if (and test-name
test-rundir) ;; #f means no dir set yet
;; (common:file-exists? test-rundir)
;; (directory? test-rundir))
(call-with-environment-variables
(list (cons "MT_TEST_NAME" (or test-name "no such test"))
(cons "MT_TEST_RUN_DIR" (or test-rundir "no test directory yet"))
|
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
|
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
|
-
+
|
(let ((cmd (configf:lookup *configdat* "triggers" trigger)))
(if cmd (mt:run-trigger cmd test-id test-rundir trigger (conc "mtconfig-" logname) test-name item-path event-time state status target runname)))))
(list
(conc state "/" status)
(conc state "/")
(conc "/" status)))
(pop-directory))
)))
)) ;; )
;; (mutex-unlock! *triggers-mutex*)
)))))
;;======================================================================
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
|