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
|
;; ##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']
;;
(define (print-changes-since data run-ids last-update tsname target runname)
(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 (if (equal? state "RUNNING")
"RUNNING"
(if (equal? state "COMPLETED")
status
"UNK")))
(cmtstr (if comment
(conc " message='" comment "' ")
" "))
(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 "']"))
((PASS SKIP WARN WAIVED) (print "##teamcity[testFinished name='" tctname "' duration='" (* 1e3 duration) "'" cmtstr details " ]"))
(else
(print "##teamcity[testFailed name='" tctname "' " cmtstr details " ]")))
(flush-output)
(hash-table-set! data testn newstat)))))
tests)))
run-ids))
now))
(define (monitor pid)
(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))
(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.")
(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)))
|
|
>
|
|
|
|
|
|
|
>
>
>
>
|
|
|
|
|
|
|
|
|
|
|
|
>
|
|
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
|
;; ##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))
(define (monitor pid)
(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)))
|
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
|
(header (db:get-header runs))
(rows (db:get-rows runs))
(run-ids-in (map (lambda (row)
(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 keys
(set! last-update (print-changes-since testdat run-ids last-update tsname target runname)))
|
<
<
>
>
>
>
|
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
(header (db:get-header runs))
(rows (db:get-rows runs))
(run-ids-in (map (lambda (row)
(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)
(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 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))
|