Megatest

  (overall #f)
  flowid
  tctname
  tname
  (event-time #f)
  details
  comment
  duration
  (printed #f))

(defstruct testrecord
  last-tdat
  

(define (tcmt:print tdat)
  (let* ((comment  (if (testdat-comment tdat)
		       (conc " message='" (testdat-comment tdat))
		       ""))
	 (details  (if (testdat-details tdat)
		       (conc " details='" (testdat-details tdat))
		       ""))
	 (flowid   (conc " flowId='" (testdat-flowid   tdat) "'"))
	 (duration (conc " duration='" (* 1e3 (testdat-duration tdat)) "'"))
	 (tcname   (conc " name='" (testdat-tctname  tdat) "'")))
    (case (string->symbol (testdat-overall tdat)) ;; (testdat-tc-type tdat)
      ((RUNNING)      (print "##teamcity[testStarted "  tcname flowid "]"))
      ((COMPLETED)
       (if (member (testdat-status tdat) '("PASS" "WARN" "SKIP" "WAIVED"))
	   (print "##teamcity[testFinished " tcname flowid comment details duration "]")
	   (print "##teamcity[testFailed "   tcname flowid comment details "]")))
      ((ignore)        #f)
      (else            (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname)))
    (flush-output)))

;; process the queue of tests gathered so far. List includes one entry for every test so far seen
;; the last record for a test is preserved. Items are only removed from the list if over 15 seconds
;; have passed since it happened. This allows for compression of COMPLETED/FAIL followed by some other
;; state/status
;;
(define (process-queue data flush-mode)
  ;; here we process tqueue and gather those over 15 seconds (configurable?) old
  (let* ((tqueue (reverse (hash-table-ref/default data 'tqueue '()))) ;; need oldest to newest
         (newtq '())
         (pqueue (make-hash-table)) ;; ( tname => ( tdat1 tdat2 ... ) ... )
         ;; (items  '())
         (targtm (- now 15))
         (leftov (if (null? tqueue)
                     '()
                     (let loop ((hed (car tqueue))
                                (tal  (cdr tqueue))
                                (new '()))
                       (let ((event-time (testdat-event-time hed))
                             (tname      (testdat-tname      hed))
                             (state      (testdat-state      hed))
                             (status     (testdat-status     hed)))
                         (cond
                          ((or flush-mode             ;; handle everything if we are in flush mode
                               (> event-time targtm)) ;; print this one
                           ;; (hash-table-set! pqueue tname (cons hed (hash-table-ref/default pqueue tname '())))
                           (set! newtq (cons hed newtq))
                           (if (null? tal)
                               new
                               (loop (car tal)
                                     (cdr tal)
                                     (if (and (equal? state "COMPLETED")
                                              (member? status '("ABORT" "CHECK" "FAIL"))) ;; keep these around
                                         (cons hed new)
                                         new))))
                          (else
                           (if (null? tal)
                               new
                               (loop (car tal)(cdr tal)(cons hed new))))))))))
    (hash-table-set! data '
    
    ;; Now have:
    ;;   leftov - items not processed, put these back in tqueue
    ;;   pqueue - candidates for printing. print but filter for COMPLETED changes
    (hash-table-set! data 'tqueue leftov) ;; handle in the future
    (hash-table-for-each
     pqueue
     (lambda (k v) ;; v is a list of tdats, if only one, just print it!
       (let ((compressed (compress-state-status v)))
         (for-each
          (lambda (tdat)
            (tcmt:print tdat))
          


         ;; (hash-table-set! data k (car (reverse v))) ;; not needed, the pqueue data is thrown away ...
             )))))
    now))




;; ##teamcity[testStarted name='suite.testName']
;; ##teamcity[testStdOut name='suite.testName' out='text']
;; ##teamcity[testStdErr name='suite.testName' out='error text']
;; ##teamcity[testFailed name='suite.testName' message='failure message' details='message and stack trace']
;; ##teamcity[testFinished name='suite.testName' duration='50']
;; 
;; flush; #f, normal call. #t, last call, print out something for NOT_STARTED, etc.
;;

;;;;;;;   (begin
;;;;;;;     (case (string->symbol newstat)
;;;;;;;       ((UNK)       ) ;; do nothing
;;;;;;;       ((RUNNING)   (print "##teamcity[testStarted name='" tctname "' flowId='" flowid "']"))
;;;;;;;       ((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)

(define (update-queue-since data run-ids last-update tsname target runname flowid flush) ;; 
  (let ((now   (current-seconds)))
;; (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)))

				       (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      (let ((new (make-testdat)))
				  (testdat-flowid-set!     new flowid)
				  (testdat-tctname-set!    new tctname)
				  (testdat-tname-set!      new tname)
				  (testdat-comment-set!    new cmtstr)
				  (testdat-details-set!    new details)
				  (testdat-duration-set!   new duration)
				  (testdat-event-time-set! new (current-seconds))
				  (testdat-overall-set!    new newstat)
				  (hash-table-set! data tname new)
				  new)))






                (hash-table-set! data 'tqueue (cons tdat tqueue))
                (hash-table-set! data tname tdat)))
            tests)))
       run-ids)))

      





































(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")))

				       (db:get-value-by-header row header "id"))
				     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 (update-queue-since testdats run-ids last-update tsname target runname flowid #f))
                     (process-queue data #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.")
	       (print-changes-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode
               (process-queue data #t)
	       (print "TCMT: All done.")
	       ))))))
;;;;; )

;; (trace print-changes-since)

;; (if (not (eq? pidres 0))	  ;; (not exitstatus))