Megatest

;;;;;;;       ((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " flowId='" flowid "']"))
;;;;;;;       (else
;;;;;;; 	(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 #!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)
	 (let* ((tests (rmt:get-tests-for-run run-id "%" '() '() #f #f #f #f #f #f last-update #f)))
	   ;; (print "DEBUG: got tests=" tests)

		     (status   (db:test-get-status       test-rec))
		     (etime    (db:test-get-event_time   test-rec))
		     (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
                                ;; ((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
				       #f)))
		     (details  (if (string-match ".*html$" 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
				      (testdat-flowid-set!     new (or (testdat-flowid new)
                                                                       (if (eq? pid 0)
                                                                           tctname
                                                                           (conc hostn "-" pid))))
				      (testdat-tctname-set!    new tctname)
				      (testdat-tname-set!      new tname)
				      (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 tname tdat)
                ))
            tests)))
       run-ids)
      (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)
	 (target  (or (args:get-arg "-target")
		      (args:get-arg "-reqtarg")))

				     rows)))
	       (set! run-ids run-ids-in)))
	 ;; (print "TCMT: pidres=" pidres " exittype=" exittype " exitstatus=" exitstatus " run-ids=" run-ids)
	 (if (eq? pidres 0)
	     (begin
	       (if keys
                   (begin
                     (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)))))
    ;; 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 " "))
				 (set! pid (process-run "megatest" origargs)))
			       "Megatest job"))