︙ | | | ︙ | |
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
|
;; GLOBALS
;;======================================================================
;; Gotta have a global? Stash it in the *global* hash table.
;;
(define *global* (make-hash-table))
(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)))
;; ;; returns values: flag newlst
;; (define (remove-duplicate-completed tdats)
;; (let* ((flag #f)
;; (state (testdat-state tdat))
;; (status (testdat-status tdat))
|
|
|
>
|
>
>
>
>
>
|
>
|
>
|
|
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
|
;; 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)))
(overall (case state
((RUNNING) state)
((COMPLETED) state)
(else 'UNK))))
(case overall
((RUNNING) (print "##teamcity[testStarted " tcname flowid "]"))
((COMPLETED)
(if (member status '(PASS WARN SKIP WAIVED))
(print "##teamcity[testFinished " tcname flowid comment details duration "]")
(print "##teamcity[testFailed " tcname flowid comment details "]")))
(else
(if flush-mode
(print "##teamcity[testFailed " tcname flowid comment details "]"))))
;; (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))
|
︙ | | | ︙ | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
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)
(if (null? tqueue)
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)))))))))
|
|
|
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
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? tqueue)
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)))))))))
|
︙ | | | ︙ | |
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
;;;;;;; ((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
|
|
|
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
|
;;;;;;; ((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
|
︙ | | | ︙ | |
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
(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)))
|
>
>
|
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
|
(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-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 (current-seconds))
(testdat-overall-set! new newstat)
(hash-table-set! data tname new)
new)))
|
︙ | | | ︙ | |
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
|
(process-queue testdats 15 #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.")
(update-queue-since testdats run-ids 0 tsname target runname flowid #t) ;; call in flush mode
(process-queue data 0 #t)
(print "TCMT: All done.")
))))))
;;;;; )
;; (trace print-changes-since)
;; (if (not (eq? pidres 0)) ;; (not exitstatus))
|
|
|
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
|
(process-queue testdats 15 #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.")
(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))
|
︙ | | | ︙ | |