@@ -2684,11 +2684,11 @@ '(*TOP* (*PI* xml "version='1.0'") (testsuite))) (define (runs:update-junit-test-reporter-xml run-id) - (let* ((doc doc-template) + (let* ( (junit-test-reporter (configf:lookup *configdat* "runs" "junit-test-reporter-xml")) (junit-test-report-dir (configf:lookup *configdat* "runs" "junit-test-report-dir")) (xml-dir (if (and junit-test-reporter (equal? junit-test-reporter "yes" )) (if junit-test-report-dir junit-test-report-dir @@ -2695,12 +2695,13 @@ (conc (getenv "MT_LINKTREE") "/" (getenv "MT_TARGET") "/" (getenv "MT_RUNNAME"))) #f)) (xml-ts-name (if xml-dir (conc (getenv "MT_TESTSUITENAME")"."(string-translate (getenv "MT_TARGET") "/" ".") "." (getenv "MT_RUNNAME")) #f)) + (keyname (common:get-signature xml-ts-name)) (xml-path (if xml-dir - (conc xml-dir "/" (common:get-signature xml-ts-name) ".xml") + (conc xml-dir "/" keyname ".xml") #f)) (test-data (if xml-dir (rmt:get-tests-for-run run-id "%" '() '() ;; run-id testpatt states statuses #f #f ;; offset limit @@ -2716,62 +2717,62 @@ (begin ;((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count)))) doc) (let loop ((test (car test-data)) (tail (cdr test-data)) + (doc doc-template) (fail-cnt 0) (error-cnt 0)) (let* ((test-name (vector-ref test 2)) (test-itempath (vector-ref test 11)) (tc-name (conc test-name (if (and test-itempath (not (equal? test-itempath ""))) (conc "." (string-translate test-itempath "/" "." )) ""))) (test-state (vector-ref test 3)) (comment (vector-ref test 14)) (test-status (vector-ref test 4)) (exc-msg (conc "No bucket for State " test-state " Status " test-status)) - ;; (debug:print 0 *default-log-port* "tail:" (length tail)) - (new-doc - (cond - ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "RUNNING" )) - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress (@ (type "inProgress")))))) doc)) - ((member test-status (list "PASS" "WARN" "WAIVED")) - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) - ((member test-status (list "FAIL" "CHECK")) - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc) - (if (null? tail) - (set! fail-cnt (+ fail-cnt 1)) - (loop (car tail) (cdr tail) (+ fail-cnt 1) error-cnt))) - ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc) - (if (null? tail) - (set! error-cnt (+ error-cnt 1)) - (loop (car tail) (cdr tail) fail-cnt (+ error-cnt 1)))) - ((member test-status (list "SKIP")) - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) - (else - ((sxml-modify! `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc) - (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) - (if (null? tail) - (set! error-cnt (+ error-cnt 1))) - (loop (car tail) (cdr tail) fail-cnt (+ error-cnt 1))))) - (if (null? tail) + (new-doc (cond + ((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "RUNNING" )) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress (@ (type "inProgress")))))) doc)) + ((member test-status (list "PASS" "WARN" "WAIVED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc)) + ((member test-status (list "FAIL" "CHECK")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc)) + ((member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc)) + ((member test-status (list "SKIP")) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc)) + (else + (debug:print 0 *default-log-port* (conc "What do I do with State " test-state " Status " test-status)) + ((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc)))) + (new-error-cnt (if (member test-status (list "DEAD" "KILLED" "ABORT" "PREQ_FAIL" "PREQ_DISCARDED")) + (+ error-cnt 1) + error-cnt)) + (new-fail-cnt (if (member test-status (list "FAIL" "CHECK")) + (+ fail-cnt 1) + fail-cnt))) + (if (null? tail) (begin (debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt) - ((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) doc) + ((sxml-modify! `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc) (handle-exceptions exn (let* ((msg ((condition-property-accessor 'exn 'message) exn))) (debug:print 0 *default-log-port* (conc "WARNING: Failed to update file" xml-path". Message:" msg))) - (debug:print 0 *default-log-port* "creating xml at " xml-path) - (debug:print 0 *default-log-port* (length tail)) + (if (not (file-exists? xml-dir)) (create-directory xml-dir #t)) - (with-output-to-file xml-path - (lambda () - (print (sxml-serializer#serialize-sxml doc ns-prefixes: (list (cons 'gnm "http://foo")))))))) - (loop (car tail) (cdr tail) fail-cnt error-cnt))))) - ))) + (if (not (rmt:no-sync-get/default keyname #f)) + (begin + (rmt:no-sync-set keyname "on") + (debug:print 0 *default-log-port* "creating xml at " xml-path) + (with-output-to-file xml-path + (lambda () + (print (sxml-serializer#serialize-sxml doc ns-prefixes: (list (cons 'gnm "http://foo")))))) + (rmt:no-sync-del! keyname)) + (debug:print 0 *default-log-port* "Could not get the lock. Skip writing the xml file.")))) + (loop (car tail) (cdr tail) new-doc new-fail-cnt new-error-cnt)))))))) ;; clean cache files (define (runs:clean-cache target runname toppath) (if target (if runname