Index: tcmt.scm ================================================================== --- tcmt.scm +++ tcmt.scm @@ -13,11 +13,11 @@ ;; ;; 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) (declare (uses margs)) (declare (uses rmt)) (declare (uses common)) (declare (uses megatest-version)) @@ -34,75 +34,184 @@ ) `("-tc-repl" ) args:arg-hash 0)) + +(defstruct testdat + (tc-type #f) + (state #f) + (status #f) + (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. ;; -(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) + +(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. + (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)) + (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 (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 #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")) @@ -113,14 +222,14 @@ (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 +249,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)) + (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 testdat run-ids 0 tsname target runname flowid #t) ;; call in flush mode + (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)) ;; (begin ;; (thread-sleep! 3) ;; (loop))