| ︙ | | |
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
-
+
|
(offset 0)
(limit 500))
;; (print "runsdat: " runsdat)
(let* ((header (vector-ref runsdat 0))
(runslst (vector-ref runsdat 1))
(full-list (append res runslst))
(have-more (eq? (length runslst) limit)))
;; (debug:print 0 #f "header: " header " runslst: " runslst " have-more: " have-more)
;; (debug:print 0 *default-log-port* "header: " header " runslst: " runslst " have-more: " have-more)
(if have-more
(let ((new-offset (+ offset limit))
(next-batch (rmt:get-runs-by-patt keys runnamepatt targpatt offset limit #f)))
(debug:print-info 4 #f "More than " limit " runs, have " (length full-list) " runs so far.")
(debug:print-info 0 #f "next-batch: " next-batch)
(loop next-batch
full-list
|
| ︙ | | |
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
-
+
|
(res (hash-table-ref/default *pre-reqs-met-cache* key #f))
(useres (let ((last-time (if (vector? res) (vector-ref res 0) #f)))
(if last-time
(< (current-seconds)(+ last-time 5))
#f))))
(if useres
(let ((result (vector-ref res 1)))
(debug:print 4 #f "Using lazy value res: " result)
(debug:print 4 *default-log-port* "Using lazy value res: " result)
result)
(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode itemmaps: itemmaps)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
(define (mt:get-run-stats dbstruct run-id)
;; Get run stats from local access, move this ... but where?
|
| ︙ | | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
-
+
|
(let ((new-res (reverse res)))
;; (print " new-res: " new-res)
new-res)
(loop (car remt)
(cdr remt)
(if (member failed-test waitons)
(begin
(debug:print 0 #f "Discarding test " testn "(" test-dat ") due to " failed-test)
(debug:print 0 *default-log-port* "Discarding test " testn "(" test-dat ") due to " failed-test)
res)
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
;;======================================================================
|
| ︙ | | |
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
|
-
+
|
;; S T A T E A N D S T A T U S F O R T E S T S
;;======================================================================
;; speed up for common cases with a little logic
(define (mt:test-set-state-status-by-id run-id test-id newstate newstatus newcomment)
(if (not (and run-id test-id))
(begin
(debug:print 0 #f "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
(debug:print 0 *default-log-port* "ERROR: bad data handed to mt:test-set-state-status-by-id, run-id=" run-id ", test-id=" test-id ", newstate=" newstate)
(print-call-chain (current-error-port))
#f)
(begin
(cond
((and newstate newstatus newcomment)
(rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
((and newstate newstatus)
|
| ︙ | | |
213
214
215
216
217
218
219
220
221
222
223
|
213
214
215
216
217
218
219
220
221
222
223
|
-
+
|
(hash-table-set! *testconfigs* test-name newtcfg)
(if old-link-tree
(setenv "MT_LINKTREE" old-link-tree)
(unsetenv "MT_LINKTREE"))
newtcfg))
(if (null? tal)
(begin
(debug:print 0 #f "ERROR: No readable testconfig found for " test-name)
(debug:print 0 *default-log-port* "ERROR: No readable testconfig found for " test-name)
#f)
(loop (car tal)(cdr tal))))))))))
|