11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
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
|
;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;; 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)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))
(include "megatest-fossil-hash.scm")
(include "db_records.scm")
(define origargs (cdr (argv)))
(define remargs (args:get-args
(argv)
`( "-target"
"-reqtarg"
"-runname"
)
`("-tc-repl"
)
args:arg-hash
0))
;; ##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) ;;
(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))
(let* ((run-ids #f)
(testdat (make-hash-table))
(keys #f)
(last-update 0)
(target (or (args:get-arg "-target")
(args:get-arg "-reqtarg")))
(runname (args:get-arg "-runname"))
(tsname #f)
(flowid (conc target "/" runname)))
(if (and target runname)
(begin
(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)))
(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
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|
>
>
>
>
>
>
>
>
>
>
>
>
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
|
|
|
>
|
|
|
<
>
>
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
>
>
|
|
|
>
>
>
>
>
>
>
>
>
|
<
<
<
|
<
|
>
>
|
>
|
|
|
|
|
|
|
>
|
|
|
|
|
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
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
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
|
;;
;; Wrapper to enable running Megatest flows under teamcity
;;
;; 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 defstruct)
(use trace)
;; (trace-call-sites #t)
(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))
(include "megatest-fossil-hash.scm")
(include "db_records.scm")
(define origargs (cdr (argv)))
(define remargs (args:get-args
(argv)
`( "-target"
"-reqtarg"
"-runname"
"-delay" ;; how long to wait for unexpected changes to
)
`("-tc-repl"
)
args:arg-hash
0))
(defstruct testdat
(tc-type #f)
(state #f)
(status #f)
(overall #f)
(flowid #f)
tctname
tname
(event-time #f)
details
comment
duration
(start-printed #f)
(end-printed #f))
;;======================================================================
;; 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)))
(startp (testdat-start-printed tdat))
(endp (testdat-end-printed tdat))
(etime (testdat-event-time tdat))
(overall (case state
((RUNNING) state)
((COMPLETED) state)
(else 'UNK)))
(tstmp (conc " timestamp='" (time->string (seconds->local-time etime) "%FT%T.000") "'")))
(case overall
((RUNNING)
(if (not startp)
(begin
(print "##teamcity[testStarted " tcname flowid tstmp "]")
(testdat-start-printed-set! tdat #t))))
((COMPLETED)
(if (not startp) ;; start stanza never printed
(begin
(print "##teamcity[testStarted " tcname flowid tstmp "]")
(testdat-start-printed-set! tdat #t)))
(if (not endp)
(begin
(if (member status '(PASS WARN SKIP WAIVED))
(print "##teamcity[testFinished" tcname flowid comment details duration "]")
(print "##teamcity[testFailed " tcname flowid comment details "]"))
(testdat-end-printed-set! tdat #t))))
(else
(if flush-mode
(begin
(if (not startp)
(begin
(print "##teamcity[testStarted " tcname flowid tstmp "]")
(testdat-start-printed-set! tdat #t)))
(if (not endp)
(begin
(print "##teamcity[testFailed " tcname flowid comment details "]")
(testdat-end-printed-set! tdat #t)))))))
;; (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))
;; (event-time (testdat-event-time tdat))
;; (tname (testdat-tname tdat)))
;; (let loop ((hed (car tdats))
;; (tal (cdr tdats))
;; (new '()))
;; (if (and (equal? state "COMPLETED")
;; (equal? tname (testdat-tname hed))
;; (equal? state (testdat-state hed))) ;; we have a duplicate COMPLETED call
;; (begin
;; (set! flag #t) ;; A changed completed
;; 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 age flush-mode)
;; here we process tqueue and gather those over 15 seconds (configurable?) old
(let* ((print-time (- (current-seconds) age)) ;; print stuff over 15 seconds old
(tqueue-raw (hash-table-ref/default data 'tqueue '()))
(tqueue (reverse (delete-duplicates tqueue-raw ;; REMOVE duplicates by testname and state
(lambda (a b)
(and (equal? (testdat-tname a)(testdat-tname b)) ;; need oldest to newest
(equal? (testdat-state a) (testdat-state b)))))))) ;; "COMPLETED")
;; (equal? (testdat-state b) "COMPLETED")))))))
(if (not (null? tqueue))
(hash-table-set!
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? tal)
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)))))))))
;; ##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)
;; (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
(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.
(is-top (db:test-get-is-toplevel test-rec))
(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))
(etime (db:test-get-event_time 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))
(hostn (db:test-get-host test-rec))
(pid (db:test-get-process_id 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 (if is-top
#f
(let ((new (or prev-tdat (make-testdat)))) ;; recycle the record so we keep track of already printed items
(testdat-flowid-set! new (or (testdat-flowid new)
(if (eq? pid 0)
tctname
(conc hostn "-" pid))))
(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 etime) ;; (current-seconds))
(testdat-overall-set! new newstat)
(hash-table-set! data tname new)
new))))
(if (not is-top)
(hash-table-set! data 'tqueue (cons tdat tqueue)))
(hash-table-set! data tname tdat)
))
tests)))
run-ids)
now))
(define (monitor pid)
(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"))
(tsname #f)
(flowid (conc target "/" runname))
(tdelay (string->number (or (args:get-arg "-delay") "15"))))
(if (and target runname)
(begin
(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)))
(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
|
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
|
(db:get-value-by-header row header "id"))
rows)))
(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)
(print-changes-since testdat run-ids 0 tsname target runname flowid #t) ;; call in flush mode
(print "TCMT: All done.")
)))))))
;; (if (not (eq? pidres 0)) ;; (not exitstatus))
;; (begin
;; (thread-sleep! 3)
;; (loop))
;; (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)
|
>
|
>
|
|
>
|
>
>
>
|
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
|
(db:get-value-by-header row header "id"))
rows)))
(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
(begin
(set! last-update (- (update-queue-since testdats run-ids last-update tsname target runname flowid #f) 5))
(process-queue testdats tdelay #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))
;; (begin
;; (thread-sleep! 3)
;; (loop))
;; (print "Process: megatest " (string-intersperse origargs " ") " is done.")))))
(define (main)
|