Megatest

Check-in [a5e90cd118]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Refactored and ready for new mechanism
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.64-tcintegration
Files: files | file ages | folders
SHA1: a5e90cd11826ca72617e2d2006d27f5bc1943606
User & Date: mrwellan on 2017-08-04 18:15:18
Other Links: branch diff | manifest | tags
Context
2017-08-06
23:57
Refactoring for delayed output mostly done. Bugs remain. check-in: 790604d640 user: matt tags: v1.64-tcintegration
2017-08-04
18:15
Refactored and ready for new mechanism check-in: a5e90cd118 user: mrwellan tags: v1.64-tcintegration
2017-08-03
17:51
Partially implemented teamcity support changes as requested. WIP. check-in: 264909ff3b user: mrwellan tags: v1.64-tcintegration
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Modified tcmt.scm from [84e403e19f] to [e3a7746dd2].

︙︙
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

		    )
		 `("-tc-repl"
		   )
		 args:arg-hash
		 0))

(defstruct testdat
  tc-type
  state
  status

  flowid
  tctname
  event_time
  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))
                     "")))



    (case (testdat-tc-type tdat)
      ((test-start)
       (print "##teamcity[testStarted name='" (testdat-tctname tdat) "' flowId='" (testdat-flowid tdat) "']"))
      ((test-end)
       (print "##teamcity[testFinished name='" (testdat-tctname tdat) "' duration='" (* 1e3 (testdat-duration tdat)) "'"
              comment
              details
              " flowId='" flowid "']"))
      ((test-failed)
       (print "##teamcity[testFailed name='" (testdat-tctname tdat) "' " comment details " flowId='" flowid "']")))))

;; ##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)))








|
|
|
>








|
|
|
|
|
|
>
>
>

|
<
<
|
<
<
<
|
<



















|
|
|
|

|
|
|
|
|
<






|

|
|
|
|

|
|
|
>
>
>
>
>
>

>
>
>
>
















|
|








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

		    )
		 `("-tc-repl"
		   )
		 args:arg-hash
		 0))

(defstruct testdat
  (tc-type #f)
  (state   #f)
  (status  #f)
  (overall #f)
  flowid
  tctname
  event_time
  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 "]")))))


;; ##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 (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))
    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)))
︙︙
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187

				       (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))








|





|








174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194

				       (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 testdats 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 testdats 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))
︙︙

This page was generated in about 0.106s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00