463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
|
(db:test-get-host test-info)
(begin
(debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
(exit))))
(test-pid (db:test-get-process_id test-info)))
(cond
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE or KILLED, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(rmt:general-call 'set-test-start-time #f test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
|
|
>
|
|
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
|
(db:test-get-host test-info)
(begin
(debug:print 0 *default-log-port* "ERROR: failed to find a record for test-id " test-id ", exiting.")
(exit))))
(test-pid (db:test-get-process_id test-info)))
(cond
;; -mrw- I'm removing KILLREQ from this list so that a test in KILLREQ state is treated as a "do not run" flag.
((or (member (db:test-get-state test-info) '("INCOMPLETE" "KILLED" "UNKNOWN" "STUCK")) ;; prior run of this test didn't complete, go ahead and try to rerun
(member (db:test-get-status test-info) '("ABORT"))) ;; prior run of this test ABORTed, ok to rerun without reset of state
(debug:print 0 *default-log-port* "INFO: test is INCOMPLETE, KILLED or ABORT, treat this execute call as a rerun request")
;; (tests:test-force-state-status! run-id test-id "REMOTEHOSTSTART" "n/a")
(rmt:general-call 'set-test-start-time #f test-id)
(rmt:test-set-state-status run-id test-id "REMOTEHOSTSTART" "n/a" #f)
) ;; prime it for running
((member (db:test-get-state test-info) '("RUNNING" "REMOTEHOSTSTART"))
(if (process:alive-on-host? test-host test-pid)
|
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
|
(debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
((> running-cnt 0)
(debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
(let ((kill-cnt (launch:kill-tests-if-dead run-id)))
(if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
(launch:end-of-run-check run-id)))) ;;todo
(else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
(let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
(if (> (length not-completed-tests) 0)
(let loop ((running-test (car not-completed-tests))
(tal (cdr not-completed-tests)))
(let* ((test-name (vector-ref running-test 2))
(item-path (vector-ref running-test 11)))
(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
(if (not (null? tal))
(loop (car tal) (cdr tal)))))))))))
(define (launch:is-test-alive host pid)
(if (and host pid (not (equal? host "n/a")))
(let* ((cmd (conc "ssh " host " pstree -A " pid))
(output (with-input-from-pipe cmd read-lines)))
(debug:print 2 *default-log-port* "Running " cmd " received " output)
(if (eq? (length output) 0)
#f
#t))
#t))
(define (launch:kill-tests-if-dead run-id)
(let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
(let loop ((running-test (car running-tests))
(tal (cdr running-tests))
(kill-cnt 0))
(let* ((test-name (vector-ref running-test 2))
(item-path (vector-ref running-test 11))
(test-id (vector-ref running-test 0))
(host (vector-ref running-test 6))
|
|
|
|
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
|
(debug:print 0 *default-log-port* "There are " running-cnt " tests running." ))
((> running-cnt 0)
(debug:print 0 *default-log-port* "running cnt > 0 but <= 3 kill-running-tests-if-dead" )
(let ((kill-cnt (launch:kill-tests-if-dead run-id)))
(if (and all-test-launched (equal? all-test-launched "yes") (eq? kill-cnt running-cnt))
(launch:end-of-run-check run-id)))) ;;todo
(else (debug:print 0 *default-log-port* "Should it get here?? May be everything is not launched yet. Running test cnt:" running-cnt " Not completed test cnt:" not-completed-cnt)
(let* ((not-completed-tests (rmt:get-tests-for-run run-id "%" `("NOT_STARTED" "RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
(if (> (length not-completed-tests) 0)
(let loop ((running-test (car not-completed-tests))
(tal (cdr not-completed-tests)))
(let* ((test-name (vector-ref running-test 2))
(item-path (vector-ref running-test 11)))
(debug:print 0 *default-log-port* "test " test-name "/" item-path " not completed")
(if (not (null? tal))
(loop (car tal) (cdr tal)))))))))))
(define (launch:is-test-alive host pid)
(if (and host pid (not (equal? host "n/a")))
(let* ((cmd (conc "ssh " host " pstree -A " pid))
(output (with-input-from-pipe cmd read-lines)))
(debug:print 2 *default-log-port* "Running " cmd " received " output)
(if (eq? (length output) 0)
#f
#t))
#t))
(define (launch:kill-tests-if-dead run-id)
(let* ((running-tests (rmt:get-tests-for-run run-id "%" `("RUNNING" "LAUNCHING" "LAUNCHED" "REMOTEHOSTSTART") `() #f #f #f #f #f #f #f #f)))
(let loop ((running-test (car running-tests))
(tal (cdr running-tests))
(kill-cnt 0))
(let* ((test-name (vector-ref running-test 2))
(item-path (vector-ref running-test 11))
(test-id (vector-ref running-test 0))
(host (vector-ref running-test 6))
|