| ︙ | | | ︙ | |
16
17
18
19
20
21
22
23
24
25
26
27
28
29
|
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
>
|
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
|
(declare (uses common))
(declare (uses items))
(declare (uses runconfig))
(declare (uses tests))
(declare (uses server))
(declare (uses runs))
(declare (uses rmt))
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
|
| ︙ | | | ︙ | |
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
(let ((result (vector-ref res 1)))
(debug:print 4 "Using lazy value res: " result)
result)
(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))
(hash-table-set! *pre-reqs-met-cache* key (vector (current-seconds) newres))
newres))))
;; Get run stats from local access, move this ... but where?
(define (mt:get-run-stats)
(db:get-run-stats #f))
|
>
<
|
|
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
(let ((result (vector-ref res 1)))
(debug:print 4 "Using lazy value res: " result)
result)
(let ((newres (rmt:get-prereqs-not-met run-id waitons ref-item-path mode: mode)))
(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?
(db:get-run-stats dbstruct run-id))
(define (mt:discard-blocked-tests run-id failed-test tests test-records)
(if (null? tests)
tests
(begin
(debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test)
(let loop ((testn (car tests))
|
| ︙ | | | ︙ | |
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
res
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:process-triggers test-id newstate newstatus)
(let* ((test-dat (rmt:get-test-info-by-id test-id))
(test-rundir (db:test-get-rundir test-dat))
(test-name (db:test-get-testname test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
(if (and (file-exists? test-rundir)
|
|
|
>
|
>
|
|
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
res
(cons testn res)))))))))
;;======================================================================
;; T R I G G E R S
;;======================================================================
(define (mt:process-triggers run-id test-id newstate newstatus)
(let* ((test-dat (rmt:get-test-info-by-id run-id test-id))
(test-rundir ;; (rmt:sdb-qry 'getstr ;; (filedb:get-path *fdb*
(db:test-get-rundir test-dat)) ;; ) ;; )
(test-name (db:test-get-testname test-dat))
(tconfig #f)
(state (if newstate newstate (db:test-get-state test-dat)))
(status (if newstatus newstatus (db:test-get-status test-dat))))
(if (and test-rundir ;; #f means no dir set yet
(file-exists? test-rundir)
(directory? test-rundir))
(begin
(push-directory test-rundir)
(set! tconfig (mt:lazy-read-test-config test-name))
(pop-directory)
(for-each (lambda (trigger)
(let ((cmd (configf:lookup tconfig "triggers" trigger))
|
| ︙ | | | ︙ | |
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
|
(conc "/" status)))))))
;;======================================================================
;; 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 test-id newstate newstatus newcomment)
(cond
((and newstate newstatus newcomment)
(rmt:general-call 'state-status-msg newstate newstatus newcomment test-id))
((and newstate newstatus)
(rmt:general-call 'state-status newstate newstatus test-id))
(else
(if newstate (rmt:general-call 'set-test-state newstate test-id))
(if newstatus (rmt:general-call 'set-test-status newstatus test-id))
(if newcomment (rmt:general-call 'set-test-comment newcomment test-id))))
(mt:process-triggers test-id newstate newstatus)
#t)
(define (mt:lazy-get-test-info-by-id test-id)
(let* ((tdat (hash-table-ref/default *test-info* test-id #f)))
(if (and tdat
(< (current-seconds)(+ (vector-ref tdat 0) 10)))
(vector-ref tdat 1)
;; no need to update *test-info* as that is done in cdb:get-test-info-by-id
(cdb:get-test-info-by-id *runremote* test-id))))
|
|
|
|
|
|
|
|
<
<
<
<
<
<
<
<
|
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
|
(conc "/" status)))))))
;;======================================================================
;; 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)
(cond
((and newstate newstatus newcomment)
(rmt:general-call 'state-status-msg run-id newstate newstatus newcomment test-id))
((and newstate newstatus)
(rmt:general-call 'state-status run-id newstate newstatus test-id))
(else
(if newstate (rmt:general-call 'set-test-state run-id newstate test-id))
(if newstatus (rmt:general-call 'set-test-status run-id newstatus test-id))
(if newcomment (rmt:general-call 'set-test-comment run-id newcomment test-id))))
(mt:process-triggers run-id test-id newstate newstatus)
#t)
(define (mt:lazy-read-test-config test-name)
(let ((tconf (hash-table-ref/default *testconfigs* test-name #f)))
(if tconf
tconf
(let ((test-dirs (tests:get-tests-search-path *configdat*)))
(let loop ((hed (car test-dirs))
(tal (cdr test-dirs)))
|
| ︙ | | | ︙ | |