3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
|
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
|
-
+
-
+
-
+
-
+
-
+
-
+
-
+
-
+
|
(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))
(new-doc (cond
((member test-state (list "RUNNING" ))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inProgress)))) doc))
((member test-state (list "LAUNCHED" "REMOTEHOSTSTART" "NOT_STARTED"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (inQueue)))) doc))
((member test-status (list "PASS" "WARN" "WAIVED"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name))))) doc))
((member test-status (list "FAIL" "CHECK"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "failure")))))) doc))
((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"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((sxml-modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,comment) (type "error")))))) doc))
((member test-status (list "SKIP"))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (skipped (@ (type "skipped")))))) doc))
((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))
((modify `("testsuite" insert-into (testcase (@ (name ,tc-name)) (failure (@ (message ,exc-msg) (type "error")))))) doc))))
((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)
(let* ((final-doc ((modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
(let* ((final-doc ((sxml-modify `("testsuite" insert-into (@ (name ,xml-ts-name) (tests ,tests-count) (errors ,error-cnt) (failures ,fail-cnt)))) new-doc)))
(debug:print 0 *default-log-port* "modify attrib error=" error-cnt " fail= " fail-cnt)
(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 ", exn=" exn)))
(if (not (file-exists? xml-dir))
|