Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -189,12 +189,13 @@ ;;;;;;; (print "##teamcity[testFailed name='" tctname "' " cmtstr details " flowId='" flowid "']"))) ;;;;;;; (flush-output) ;; (trace rmt:get-tests-for-run) -(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; - (let ((now (current-seconds))) +(define (update-queue-since data run-ids last-update tsname target runname flowid flush #!key (delay-flag #t)) ;; + (let ((now (current-seconds)) + (still-running #f)) ;; (handle-exceptions ;; exn ;; (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) (for-each (lambda (run-id) @@ -214,24 +215,43 @@ (duration (or (any->number (db:test-get-run_duration test-rec)) 0)) (comment (db:test-get-comment test-rec)) (logfile (db:test-get-final_logf test-rec)) (hostn (db:test-get-host test-rec)) (pid (db:test-get-process_id test-rec)) + (test-cont (> (+ etime duration 40) (current-seconds))) ;; test has not been over for more than 20 seconds + (adj-state (if delay-flag + (if test-cont + (begin + (set! still-running #t) + "RUNNING") + state) + state)) (newstat (cond - ((equal? state "RUNNING") "RUNNING") - ((equal? state "COMPLETED") status) + ;; ((or (not delay-flag) + ;; (< (+ etime duration) + ;; (- (current-seconds) 10))) + ;; (print "Skipping as delay hasn't hit") "RUNNING") + ((equal? adj-state "RUNNING") + (set! still-running #t) + "RUNNING") + ((equal? adj-state "COMPLETED") + status) (flush (conc state "/" status)) (else "UNK"))) (cmtstr (if (and (not flush) comment) comment (if flush - (conc "Test ended in state/status=" state "/" status (if (string-match "^\\s*$" comment) - ", no Megatest comment found." - (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers + (conc "Test ended in state/status=" + state "/" status + (if (string-match "^\\s*$" comment) + ", no Megatest comment found." + (conc ", Megatest comment=\"" comment "\""))) ;; special case, we are handling stragglers #f))) (details (if (string-match ".*html$" logfile) - (conc *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile) + (conc *toppath* "/lt/" target "/" runname "/" testname + (if (equal? itempath "") "/" (conc "/" itempath "/")) + logfile) #f)) (prev-tdat (hash-table-ref/default data tname #f)) (tdat (if is-top #f (let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items @@ -239,27 +259,27 @@ (if (eq? pid 0) tctname (conc hostn "-" pid)))) (testdat-tctname-set! new tctname) (testdat-tname-set! new tname) - (testdat-state-set! new state) + (testdat-state-set! new adj-state) (testdat-status-set! new status) (testdat-comment-set! new cmtstr) (testdat-details-set! new details) (testdat-duration-set! new duration) (testdat-event-time-set! new etime) ;; (current-seconds)) (testdat-overall-set! new newstat) (hash-table-set! data tname new) new)))) (if (not is-top) - (hash-table-set! data 'tqueue (cons tdat tqueue))) + (hash-table-set! data 'tqueue (cons tdat tqueue))) (hash-table-set! data tname tdat) )) tests))) run-ids) - now)) - + (list now still-running))) + (define (monitor pid) (let* ((run-ids '()) (testdats (make-hash-table)) ;; each entry is a list of testdat structs (keys #f) (last-update 0) @@ -302,30 +322,46 @@ ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) (if (eq? pidres 0) (begin (if keys (begin - (set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 5)) + (set! last-update (- (car (update-queue-since testdats run-ids last-update tsname target runname flowid #f delay-flag: #t)) 5)) (process-queue testdats tdelay #f))) (thread-sleep! 3) - (loop)) - (begin - ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) - (print "TCMT: processing any tests that did not formally complete.") - (update-queue-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode - (process-queue testdats 0 #t) - (print "TCMT: All done.") - )))))) + (loop))))) + ;; the megatest runner is done - now wait for all processes to be COMPLETED or NO Processes to be RUNNING > 1 minute + (let loop () + (let* ((new-last-update-info (update-queue-since testdats run-ids last-update tsname target runname flowid #f delay-flag: #t)) + (still-running (cadr new-last-update-info)) + (new-last-update (- (car new-last-update-info) 5))) + (process-queue testdats tdelay #f) + (if still-running + (begin + (print "TCMT: Tests still running, keep watching...") + (thread-sleep! 3) + (loop))))) + + ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids) + (print "TCMT: processing any tests that did not formally complete.") + (update-queue-since testdats run-ids 0 tsname target runname flowid #t #f delay-flag: #f) ;; call in flush mode + (process-queue testdats 0 #t) + (print "TCMT: All done.") + )) + ;;;;; ) ;; (trace print-changes-since) ;; (if (not (eq? pidres 0)) ;; (not exitstatus)) ;; (begin ;; (thread-sleep! 3) ;; (loop)) ;; (print "Process: megatest " (string-intersperse origargs " ") " is done."))))) + +(if (file-exists? ".tcmtrc") + (load ".tcmtrc")) + (define (main) (let* ((mt-done #f) (pid #f) (th1 (make-thread (lambda () (print "Running megatest " (string-intersperse origargs " "))