437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
|
(set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(print "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...")
(let ((th1 (make-thread (lambda ()
(print "set test to COMPLETED/ABORT begin.")
(rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal")
(print "set test to COMPLETED/ABORT complete.")
(print "Killed by signal " signum ". Exiting")
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 20)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
|
|
|
|
|
|
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
|
(set! tconfigreg (tests:get-all)) ;; mapping of testname => test source path
(let ((sighand (lambda (signum)
;; (signal-mask! signum) ;; to mask or not? seems to cause issues in exiting
(if (eq? signum signal/stop)
(debug:print-error 0 *default-log-port* "attempt to STOP process. Exiting."))
(set! *time-to-exit* #t)
(debug:print 0 *default-log-port* "Received signal " signum ", cleaning up before exit (set this test to COMPLETED/ABORT) . Please wait...")
(let ((th1 (make-thread (lambda ()
(debug:print 0 *default-log-port* "set test to COMPLETED/ABORT begin.")
(rmt:test-set-state-status run-id test-id "COMPLETED" "ABORT" "received kill signal")
(debug:print 0 *default-log-port* "set test to COMPLETED/ABORT complete.")
(debug:print 0 *default-log-port* "Killed by signal " signum ". Exiting")
(exit 1))))
(th2 (make-thread (lambda ()
(thread-sleep! 20)
(debug:print 0 *default-log-port* "Done")
(exit 4)))))
(thread-start! th2)
(thread-start! th1)
|
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
|
(apply print launch-results)
(print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this"))
#:append))
(debug:print 2 *default-log-port* "Launching completed, updating db")
(debug:print 2 *default-log-port* "Launch results: " launch-results)
(if (not launch-results)
(begin
(print "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now")
;; (sqlite3:finalize! db)
;; good ole "exit" seems not to work
;; (_exit 9)
;; but this hack will work! Thanks go to Alan Post of the Chicken email list
;; NB// Is this still needed? Should be safe to go back to "exit" now?
(process-signal (current-process-id) signal/kill)
))
|
|
|
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
|
(apply print launch-results)
(print "NOTE: launched \"" fullcmd "\"\n but did not wait for it to proceed. Add the following to megatest.config \n[setup]\nlaunchwait yes\n if you have problems with this"))
#:append))
(debug:print 2 *default-log-port* "Launching completed, updating db")
(debug:print 2 *default-log-port* "Launch results: " launch-results)
(if (not launch-results)
(begin
(debug:print 0 *default-log-port* "ERROR: Failed to run " (string-intersperse fullcmd " ") ", exiting now")
;; (sqlite3:finalize! db)
;; good ole "exit" seems not to work
;; (_exit 9)
;; but this hack will work! Thanks go to Alan Post of the Chicken email list
;; NB// Is this still needed? Should be safe to go back to "exit" now?
(process-signal (current-process-id) signal/kill)
))
|