40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
|
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
|
(defstruct testdat
(tc-type #f)
(state #f)
(status #f)
(overall #f)
flowid
tctname
tname
event_time
(event-time #f)
details
comment
duration)
(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 (testdat-tc-type tdat)
((test-start) (print "##teamcity[testStarted " tctname flowid "]"))
((test-end) (print "##teamcity[testFinished " tctname flowid comment details duration "]"))
((test-failed) (print "##teamcity[testFailed " tctname flowid comment details "]")))))
(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)))
;; ##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 (print-changes-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 (test-rec)
(let* ((testn (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))
(tdat (hash-table-ref/default data testn
(let ((new (make-testdat)))
(testdat-flowid-set! new flowid)
(testdat-tctname-set! new tctname)
(testdat-event_time-set! new (current-seconds))
(hash-table-set! data testn new))))
(prevstat (testdat-overall tdat)))
;; (print "DEBUG: testn=" testn " state=" state " status=" status " prevstat=" prevstat " newstat=" newstat)
(cond
((and (not (testdat-state tdat)) ;; first time through
(equal? state "COMPLETED")) ;;
(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))
(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)))
(let* ((runs (rmt:get-runs-by-patt keys
runname
|
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
|
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
|
-
+
+
+
+
|
(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
(print "TCMT: All done.")
)))))))
))))))
;;;;; )
;; (trace print-changes-since)
;; (if (not (eq? pidres 0)) ;; (not exitstatus))
;; (begin
;; (thread-sleep! 3)
;; (loop))
;; (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)
|