Megatest

Changes On Branch a5e90cd11826ca72
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Hide Diff Patch Unified Diff

Changes In Branch v1.64-tcintegration Through [a5e90cd118] Excluding Merge-Ins

This is equivalent to a diff from 3a8e2b2276 to a5e90cd118

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
00:05
Fixed possible memory growth problem where used dbstructs were not being pushed back on the stack check-in: 6cd5eb771a user: matt tags: v1.64
2017-08-03
23:02
Enforced full sync every hour check-in: 3dffe8fa8a user: matt tags: v1.64-bad-full-sync-fix
22:26
Updated with latest changes from v1.64 check-in: 5a8ae7b6c4 user: matt tags: v1.64-areas-dashboard
17:51
Partially implemented teamcity support changes as requested. WIP. check-in: 264909ff3b user: mrwellan tags: v1.64-tcintegration
16:15
Remove the added-on local access support in dashboard, rely instead on rmt built-in support. Improved the refresh button behavior. Added DEAD to statuses to clear in -rerun-clean. check-in: 3a8e2b2276 user: mrwellan tags: v1.64
2017-07-31
14:23
Bump version to v1.6428 check-in: 7cdeaee37d user: mrwellan tags: v1.64

Modified tcmt.scm from [3e1895cf52] to [e3a7746dd2].

︙︙
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

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








|








11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

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

(declare (uses margs))
(declare (uses rmt))
(declare (uses common))
(declare (uses megatest-version))

(include "megatest-fossil-hash.scm")
︙︙
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

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

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








>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>


















|
|
|
|

|
|
|
|
|
<






|

|
|
|
|

|
|
|
>
>
>
>
>
>

>
>
>
>
















|
|








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

		    "-runname"
		    )
		 `("-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)))
︙︙
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158

				       (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.102s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00