Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -13,11 +13,14 @@ ;; ;; 1. Run the megatest process and pass it all the needed parameters ;; 2. Every five seconds check for state/status changes and print the info ;; -(use srfi-1 posix srfi-69 srfi-18 regex) +(use srfi-1 posix srfi-69 srfi-18 regex defstruct) + +(use trace) +;; (trace-call-sites #t) (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) (declare (uses megatest-version)) @@ -29,98 +32,243 @@ (define remargs (args:get-args (argv) `( "-target" "-reqtarg" "-runname" + "-delay" ;; how long to wait for unexpected changes to ) `("-tc-repl" ) args:arg-hash 0)) -;; ##teamcity[testStarted name='suite.testName'] +(defstruct testdat + (tc-type #f) + (state #f) + (status #f) + (overall #f) + flowid + tctname + tname + (event-time #f) + details + comment + duration + (start-printed #f) + (end-printed #f)) + +;;====================================================================== +;; GLOBALS +;;====================================================================== + +;; Gotta have a global? Stash it in the *global* hash table. +;; +(define *global* (make-hash-table)) + +(define (tcmt:print tdat flush-mode) + (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) "'")) + (state (string->symbol (testdat-state tdat))) + (status (string->symbol (testdat-status tdat))) + (startp (testdat-start-printed tdat)) + (endp (testdat-end-printed tdat)) + (etime (testdat-event-time tdat)) + (overall (case state + ((RUNNING) state) + ((COMPLETED) state) + (else 'UNK))) + (tstmp (conc " timestamp='" etime "'"))) + (case overall + ((RUNNING) + (if (not startp) + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-start-printed-set! tdat #t)))) + ((COMPLETED) + (if (not startp) ;; start stanza never printed + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-start-printed-set! tdat #t))) + (if (not endp) + (begin + (if (member status '(PASS WARN SKIP WAIVED)) + (print "##teamcity[testFinished" tcname flowid comment details duration "]") + (print "##teamcity[testFailed " tcname flowid comment details "]")) + (testdat-end-printed-set! tdat #t)))) + (else + (if flush-mode + (begin + (if (not startp) + (begin + (print "##teamcity[testStarted " tcname flowid tstmp "]") + (testdat-started-printed-set! tdat #t))) + (if (not endp) + (begin + (print "##teamcity[testFailed " tcname flowid comment details "]") + (testdat-end-printed-set! tdat #t))))))) + ;; (print "ERROR: tc-type \"" (testdat-tc-type tdat) "\" not recognised for " tcname))) + (flush-output))) + +;; ;; returns values: flag newlst +;; (define (remove-duplicate-completed tdats) +;; (let* ((flag #f) +;; (state (testdat-state tdat)) +;; (status (testdat-status tdat)) +;; (event-time (testdat-event-time tdat)) +;; (tname (testdat-tname tdat))) +;; (let loop ((hed (car tdats)) +;; (tal (cdr tdats)) +;; (new '())) +;; (if (and (equal? state "COMPLETED") +;; (equal? tname (testdat-tname hed)) +;; (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call +;; (begin +;; (set! flag #t) ;; A changed completed + +;; 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 age flush-mode) + ;; here we process tqueue and gather those over 15 seconds (configurable?) old + (let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old + (tqueue-raw (hash-table-ref/default data 'tqueue '())) + (tqueue (reverse (delete-duplicates tqueue-raw ;; REMOVE duplicates by testname and state + (lambda (a b) + (and (equal? (testdat-tname a)(testdat-tname b)) ;; need oldest to newest + (equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED") + ;; (equal? (testdat-state b) "COMPLETED"))))))) + (if (null? tqueue) + (print "Nothing to do!") + (hash-table-set! + data + 'tqueue + (let loop ((hed (car tqueue)) ;; by this point all duplicates by state COMPLETED are removed + (tal (cdr tqueue)) + (rem '())) + (if (> print-time (testdat-event-time hed)) ;; event happened over 15 seconds ago + (begin + (tcmt:print hed flush-mode) + (if (null? tal) + rem ;; return rem to be processed in the future + (loop (car tal)(cdr tal) rem))) + (if (null? tal) + (cons hed rem) ;; return rem + hed for future processing + (loop (car tal)(cdr tal)(cons hed rem))))))))) + + ;; ##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. ;; -(define (print-changes-since data run-ids last-update tsname target runname flowid flush) ;; + +;;;;;;; (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) + +;; (trace rmt:get-tests-for-run) + +(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))) - ;; (print "DEBUG: got tests=" tests) - (for-each - (lambda (testdat) - (let* ((testn (db:test-get-fullname testdat)) - (testname (db:test-get-testname testdat)) - (itempath (db:test-get-item-path testdat)) - (tctname (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" ".")))) - (state (db:test-get-state testdat)) - (status (db:test-get-status testdat)) - (duration (or (any->number (db:test-get-run_duration testdat)) 0)) - (comment (db:test-get-comment testdat)) - (logfile (db:test-get-final_logf testdat)) - (prevstat (hash-table-ref/default data testn #f)) - (newstat (cond - ((equal? state "RUNNING") "RUNNING") - ((equal? state "COMPLETED") status) - (flush (conc state "/" status)) - (else "UNK"))) - (cmtstr (if (and (not flush) comment) - (conc " message='" comment "' ") - (if flush - (conc "message='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 - " "))) - (details (if (string-match ".*html$" logfile) - (conc " details='" *toppath* "/lt/" target "/" runname "/" testname (if (equal? itempath "") "/" (conc "/" itempath "/")) logfile "' ") - ""))) - - ;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat) - (if (or (not prevstat) - (not (equal? prevstat newstat))) - (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) - (hash-table-set! data testn newstat))))) - tests))) - run-ids)) - now)) - +;; (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) + (for-each + (lambda (test-rec) + (let* ((tqueue (hash-table-ref/default data 'tqueue '())) ;; NOTE: the key is a symbol! This allows keeping disparate info in the one hash, lazy but a quick solution for right now. + (is-top (db:test-get-is-toplevel test-rec)) + (tname (db:test-get-fullname test-rec)) + (testname (db:test-get-testname test-rec)) + (itempath (db:test-get-item-path test-rec)) + (tctname (if (string=? itempath "") testname (conc testname "." (string-translate itempath "/" ".")))) + (state (db:test-get-state test-rec)) + (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)) + (newstat (cond + ((equal? state "RUNNING") "RUNNING") + ((equal? 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 flowid) + (testdat-tctname-set! new tctname) + (testdat-tname-set! new tname) + (testdat-state-set! new 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) + now)) + (define (monitor pid) - (let* ((run-ids #f) - (testdat (make-hash-table)) + (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"))) (runname (args:get-arg "-runname")) (tsname #f) - (flowid (conc target "/" runname))) + (flowid (conc target "/" runname)) + (tdelay (string->number (or (args:get-arg "-delay") "15")))) (if (and target runname) (begin (launch:setup) (set! keys (rmt:get-keys)))) (set! tsname (common:get-testsuite-name)) (print "TCMT: for testsuite=" tsname " found runname=" runname ", target=" target ", keys=" keys " and successfully ran launch:setup. Using " flowid " as the flowId.") (let loop () - (handle-exceptions - exn - ;; (print "Process done.") - (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) + ;;;;;; (handle-exceptions + ;;;;;; exn + ;;;;;; ;; (print "Process done.") + ;;;;;; (begin (print-call-chain) (print "Error message: " ((condition-property-accessor 'exn 'message) exn))) (let-values (((pidres exittype exitstatus) (process-wait pid #t))) (if (and keys (or (not run-ids) (null? run-ids))) @@ -140,19 +288,25 @@ (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 - (set! last-update (print-changes-since testdat run-ids last-update tsname target runname flowid #f))) - (thread-sleep! 3) + (begin + (set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 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.") - (print-changes-since testdat run-ids 0 tsname target runname flowid #t) ;; call in flush mode + (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.") - ))))))) + )))))) +;;;;; ) + +;; (trace print-changes-since) ;; (if (not (eq? pidres 0)) ;; (not exitstatus)) ;; (begin ;; (thread-sleep! 3) ;; (loop)) ADDED tests/fullrun/test-teamcity-run.sh Index: tests/fullrun/test-teamcity-run.sh ================================================================== --- /dev/null +++ tests/fullrun/test-teamcity-run.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +(cd ../..;make install) && RN=tcmt_m;megatest -remove-runs -target ubuntu/nfs/none -runname tcmt_m -testpatt %;\ + tcmt -run -target ubuntu/nfs/none -runname tcmt_m -testpatt % -rerun-clean 2>&1 | tee all.log | grep teamcity | tee teamcity.log +